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

diff --git a/basis/alarms/alarms-docs.factor b/basis/alarms/alarms-docs.factor
index df88f497016bf9b841c67732f7900663ced17111..446ec3d7fad85ecc06d08e9b24c6decd3c9e18f6 100644 (file)
--- a/basis/alarms/alarms-docs.factor
+++ b/basis/alarms/alarms-docs.factor
@@ -5,16 +5,16 @@ HELP: alarm
 { $class-description "An alarm. Can be passed to " { $link cancel-alarm } "." } ;\r
 \r
 HELP: add-alarm\r
-{ $values { "quot" quotation } { "time" timestamp } { "frequency" { $maybe duration } } { "alarm" alarm } }\r
-{ $description "Creates and registers an alarm to start at " { $snippet "time" } ". If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ;\r
+{ $values { "quot" quotation } { "start" duration } { "interval" { $maybe "duration/f" } } { "alarm" alarm } }\r
+{ $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." } ;\r
 \r
 HELP: later\r
 { $values { "quot" quotation } { "duration" duration } { "alarm" alarm } }\r
-{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } " from now." }\r
+{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "duration" } " offset from now." }\r
 { $examples\r
     { $unchecked-example\r
         "USING: alarms io calendar ;"\r
-        """[ "GET BACK TO WORK, Guy." print flush ] 10 minutes later drop"""\r
+        """[ "Break's over!" print flush ] 15 minutes drop"""\r
         ""\r
     }\r
 } ;\r
@@ -37,11 +37,9 @@ HELP: every
 } ;\r
 \r
 ARTICLE: "alarms" "Alarms"\r
-"The " { $vocab-link "alarms" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks without spawning a new thread." $nl\r
+"The " { $vocab-link "alarms" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks without spawning a new thread. Alarms use " { $vocab-link "monotonic-clock" } ", so they continue to work across system clock changes." $nl\r
 "The alarm class:"\r
-{ $subsections\r
-    alarm\r
-}\r
+{ $subsections alarm }\r
 "Register a recurring alarm:"\r
 { $subsections every }\r
 "Register a one-time alarm:"\r

diff --git a/basis/alarms/alarms.factor b/basis/alarms/alarms.factor
index 9943d39ad194a6d0efe5d356d3873afa6099ed94..8e48c37f8b819bd02d473987039bd0a66b0dbafa 100644 (file)
--- a/basis/alarms/alarms.factor
+++ b/basis/alarms/alarms.factor
@@ -2,12 +2,12 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs boxes calendar
 combinators.short-circuit fry heaps init kernel math.order
-namespaces quotations threads ;
+namespaces quotations threads math monotonic-clock ;
 IN: alarms
 
 TUPLE: alarm
     { quot callable initial: [ ] }
-    { time timestamp }
+    { start integer }
     interval
     { entry box } ;
 
@@ -19,30 +19,33 @@ SYMBOL: alarm-thread
 : notify-alarm-thread ( -- )
     alarm-thread get-global interrupt ;
 
-ERROR: bad-alarm-frequency frequency ;
-: check-alarm ( frequency/f -- frequency/f )
-    dup { [ duration? ] [ not ] } 1|| [ bad-alarm-frequency ] unless ;
+: normalize-argument ( obj -- nanoseconds )
+    >duration duration>nanoseconds >integer ;
 
-: <alarm> ( quot time frequency -- alarm )
-    check-alarm <box> alarm boa ;
+: <alarm> ( quot start interval -- alarm )
+    alarm new
+        swap dup [ normalize-argument ] when >>interval
+        swap dup [ normalize-argument monotonic-count + ] when >>start
+        swap >>quot
+        <box> >>entry ;
 
 : register-alarm ( alarm -- )
-    [ dup time>> alarms get-global heap-push* ]
+    [ dup start>> alarms get-global heap-push* ]
     [ entry>> >box ] bi
     notify-alarm-thread ;
 
-: alarm-expired? ( alarm now -- ? )
-    [ time>> ] dip before=? ;
+: alarm-expired? ( alarm n -- ? )
+    [ start>> ] dip <= ;
 
 : reschedule-alarm ( alarm -- )
-    dup '[ _ interval>> time+ now max ] change-time register-alarm ;
+    dup interval>> monotonic-count + >>start register-alarm ;
 
 : call-alarm ( alarm -- )
     [ entry>> box> drop ]
-    [ quot>> "Alarm execution" spawn drop ]
-    [ dup interval>> [ reschedule-alarm ] [ drop ] if ] tri ;
+    [ dup interval>> [ reschedule-alarm ] [ drop ] if ]
+    [ quot>> "Alarm execution" spawn drop ] tri ;
 
-: (trigger-alarms) ( alarms now -- )
+: (trigger-alarms) ( alarms n -- )
     over heap-empty? [
         2drop
     ] [
@@ -54,11 +57,11 @@ ERROR: bad-alarm-frequency frequency ;
     ] if ;
 
 : trigger-alarms ( alarms -- )
-    now (trigger-alarms) ;
+    monotonic-count (trigger-alarms) ;
 
 : next-alarm ( alarms -- timestamp/f )
     dup heap-empty?
-    [ drop f ] [ heap-peek drop time>> ] if ;
+    [ drop f ] [ heap-peek drop start>> ] if ;
 
 : alarm-thread-loop ( -- )
     alarms get-global
@@ -75,18 +78,16 @@ ERROR: bad-alarm-frequency frequency ;
     [ alarm-thread-loop t ] "Alarms" spawn-server
     alarm-thread set-global ;
 
-[ init-alarms ] "alarms" add-init-hook
+[ init-alarms ] "alarms2" add-startup-hook
 
 PRIVATE>
 
-: add-alarm ( quot time frequency -- alarm )
+: add-alarm ( quot start interval -- alarm )
     <alarm> [ register-alarm ] keep ;
 
-: later ( quot duration -- alarm )
-    hence f add-alarm ;
+: later ( quot duration -- alarm ) f add-alarm ;
 
-: every ( quot duration -- alarm )
-    [ hence ] keep add-alarm ;
+: every ( quot duration -- alarm ) dup add-alarm ;
 
 : cancel-alarm ( alarm -- )
     entry>> [ alarms get-global heap-delete ] if-box? ;

diff --git a/basis/bootstrap/finish-bootstrap.factor b/basis/bootstrap/finish-bootstrap.factor
index ab08aa87a9b02fa170d8cebe5f386a7cbaff74bd..35b40df97a322e967807bbd8d9e4d5547a68f14f 100644 (file)
--- a/basis/bootstrap/finish-bootstrap.factor
+++ b/basis/bootstrap/finish-bootstrap.factor
@@ -1,17 +1,19 @@
 USING: init command-line debugger system continuations
-namespaces eval kernel vocabs.loader io ;
+namespaces eval kernel vocabs.loader io destructors ;
 
 [
     boot
-    do-init-hooks
     [
-        (command-line) parse-command-line
-        load-vocab-roots
-        run-user-init
-        "e" get [ eval( -- ) ] when*
-        ignore-cli-args? not script get and
-        [ run-script ] [ "run" get run ] if*
-        output-stream get [ stream-flush ] when*
-        0 exit
-    ] [ print-error 1 exit ] recover
+        do-startup-hooks
+        [
+            (command-line) parse-command-line
+            load-vocab-roots
+            run-user-init
+            "e" get [ eval( -- ) ] when*
+            ignore-cli-args? not script get and
+            [ run-script ] [ "run" get run ] if*
+            output-stream get [ stream-flush ] when*
+            0
+        ] [ print-error 1 ] recover
+     ] with-destructors exit
 ] set-boot-quot

diff --git a/basis/bootstrap/finish-staging.factor b/basis/bootstrap/finish-staging.factor
index 49f504fd41441d34f148171aefb5c9f3a43f70b4..10d81d6ff6e9ec6f173a6193e82dd5551166aee2 100644 (file)
--- a/basis/bootstrap/finish-staging.factor
+++ b/basis/bootstrap/finish-staging.factor
@@ -3,9 +3,10 @@ io ;
 
 [
     boot
-    do-init-hooks
-    (command-line) parse-command-line
-    "run" get run
-    output-stream get [ stream-flush ] when*
-    0 exit
+    [
+        do-startup-hooks
+        (command-line) parse-command-line
+        "run" get run
+        output-stream get [ stream-flush ] when*
+    ] with-destructors 0 exit
 ] set-boot-quot

diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor
index 0b517c0e66f649fd0c4d1228d2d422fa52390b26..b011b41c4b8735fe50bacadb68fa3041de903b48 100644 (file)
--- a/basis/bootstrap/stage2.factor
+++ b/basis/bootstrap/stage2.factor
@@ -56,6 +56,7 @@ SYMBOL: bootstrap-time
     error-continuation set-global
     error set-global ; inline
 
+
 [
     ! We time bootstrap
     millis

diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor
index ef22a98c80a0dfbda684695b2015ba6caf203f0c..1564bc3ee4de3b2c158103f7df91dfa9ee201c0f 100644 (file)
--- a/basis/calendar/calendar.factor
+++ b/basis/calendar/calendar.factor
@@ -171,6 +171,11 @@ M: timestamp easter ( timestamp -- timestamp )
 : microseconds ( x -- duration ) 1000000 / 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 )
 M: integer year ;
 M: timestamp year year>> ;

diff --git a/basis/calendar/model/model.factor b/basis/calendar/model/model.factor
index 8665cc22cefe67749a59f0dca7fbe8bd490a42a8..38ad986952c224800a29ca4e4b58ca1c4a94fb9e 100644 (file)
--- a/basis/calendar/model/model.factor
+++ b/basis/calendar/model/model.factor
@@ -16,4 +16,4 @@ SYMBOL: time
     ] "Time model update" spawn drop ;\r
 \r
 f <model> time set-global\r
-[ time-thread ] "calendar.model" add-init-hook\r
+[ time-thread ] "calendar.model" add-startup-hook\r

diff --git a/basis/channels/remote/remote.factor b/basis/channels/remote/remote.factor
index 0a8887554491c777078ad001552996d3f62bd66b..4eab29fd81f15322cf6f5283c9663dfb5d4cb6ef 100644 (file)
--- a/basis/channels/remote/remote.factor
+++ b/basis/channels/remote/remote.factor
@@ -69,4 +69,4 @@ M: remote-channel from ( remote-channel -- value )
 [
     H{ } clone \ remote-channels set-global
     start-channel-node
-] "channel-registry" add-init-hook
+] "channel-registry" add-startup-hook

diff --git a/basis/cocoa/application/application.factor b/basis/cocoa/application/application.factor
index cbf8636a7537f4a3862b3d30c70a98010ee1690c..83213b47ba005ec11c6442898a74a9b96a9d214c 100644 (file)
--- a/basis/cocoa/application/application.factor
+++ b/basis/cocoa/application/application.factor
@@ -49,7 +49,7 @@ TUPLE: objc-error alien reason ;
 M: objc-error summary ( error -- )
     drop "Objective C exception" ;
 
-[ [ objc-error ] 19 setenv ] "cocoa.application" add-init-hook
+[ [ objc-error ] 19 setenv ] "cocoa.application" add-startup-hook
 
 : running.app? ( -- ? )
     #! Test if we're running a .app.

diff --git a/basis/cocoa/cocoa.factor b/basis/cocoa/cocoa.factor
index ec09f8f2ba3108a017b52b017eae01f1c146544d..34bac0a5055229e13b7a738190f577359fd3ab7e 100644 (file)
--- a/basis/cocoa/cocoa.factor
+++ b/basis/cocoa/cocoa.factor
@@ -27,7 +27,7 @@ SYMBOL: frameworks
 
 frameworks [ V{ } clone ] initialize
 
-[ frameworks get [ load-framework ] each ] "cocoa" add-init-hook
+[ frameworks get [ load-framework ] each ] "cocoa" add-startup-hook
 
 SYNTAX: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ;
 

diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor
index fce7adc04a18a73088aef343bc6123146e1880a5..4cc9554d3c4be5b84d1be3a1f09b7ceabd02fded 100755 (executable)
--- a/basis/cocoa/messages/messages.factor
+++ b/basis/cocoa/messages/messages.factor
@@ -76,13 +76,13 @@ MACRO: (send) ( selector super? -- quot )
 : super-send ( receiver args... selector -- return... ) t (send) ; inline
 
 ! Runtime introspection
-SYMBOL: class-init-hooks
+SYMBOL: class-startup-hooks
 
-class-init-hooks [ H{ } clone ] initialize
+class-startup-hooks [ H{ } clone ] initialize
 
 : (objc-class) ( name word -- class )
     2dup execute dup [ 2nip ] [
-        drop over class-init-hooks get at [ call( -- ) ] when*
+        drop over class-startup-hooks get at [ call( -- ) ] when*
         2dup execute dup [ 2nip ] [
             2drop "No such class: " prepend throw
         ] if
@@ -229,7 +229,7 @@ ERROR: no-objc-type name ;
 : class-exists? ( string -- class ) objc_getClass >boolean ;
 
 : define-objc-class-word ( quot name -- )
-    [ class-init-hooks get set-at ]
+    [ class-startup-hooks get set-at ]
     [
         [ "cocoa.classes" create ] [ '[ _ objc-class ] ] bi
         (( -- class )) define-declared

diff --git a/basis/command-line/command-line.factor b/basis/command-line/command-line.factor
index 19421359a395f96168981a6bcb37073c34a20561..f1748d37083f7ebbaba5663eb8a238f39db590c3 100644 (file)
--- a/basis/command-line/command-line.factor
+++ b/basis/command-line/command-line.factor
@@ -69,4 +69,4 @@ SYMBOL: main-vocab-hook
 : ignore-cli-args? ( -- ? )
     os macosx? "run" get "ui" = and ;
 
-[ default-cli-args ] "command-line" add-init-hook
+[ default-cli-args ] "command-line" add-startup-hook

diff --git a/basis/concurrency/distributed/distributed.factor b/basis/concurrency/distributed/distributed.factor
index 244f1d95a34c082ddda82ad597e24d066aedb952..0015b10cef444c70b0903a24545f177a7acc6981 100644 (file)
--- a/basis/concurrency/distributed/distributed.factor
+++ b/basis/concurrency/distributed/distributed.factor
@@ -60,6 +60,4 @@ M: thread (serialize) ( obj -- )
 
 [
     H{ } clone \ registered-remote-threads set-global
-] "remote-thread-registry" add-init-hook
-
-
+] "remote-thread-registry" add-startup-hook

diff --git a/basis/core-foundation/fsevents/fsevents.factor b/basis/core-foundation/fsevents/fsevents.factor
index 24ac24bb6aa9dd8114528e78b0c51a3260297688..37dbcd1e4feb4c925177c904dc760ffe6269fd52 100755 (executable)
--- a/basis/core-foundation/fsevents/fsevents.factor
+++ b/basis/core-foundation/fsevents/fsevents.factor
@@ -156,7 +156,7 @@ SYMBOL: event-stream-callbacks
 [
     event-stream-callbacks
     [ [ drop expired? not ] assoc-filter H{ } assoc-like ] change-global
-] "core-foundation" add-init-hook
+] "core-foundation" add-startup-hook
 
 : add-event-source-callback ( quot -- id )
     event-stream-counter <alien>

diff --git a/basis/core-text/core-text.factor b/basis/core-text/core-text.factor
index e431df941424ef135bd90861886a50cc4aade04e..7af6792e79845d8d14517139ba4d86f0b66513b7 100644 (file)
--- a/basis/core-text/core-text.factor
+++ b/basis/core-text/core-text.factor
@@ -149,4 +149,4 @@ SYMBOL: cached-lines
 : cached-line ( font string -- line )
     cached-lines get [ <line> ] 2cache ;
 
-[ <cache-assoc> cached-lines set-global ] "core-text" add-init-hook
+[ <cache-assoc> cached-lines set-global ] "core-text" add-startup-hook

diff --git a/basis/core-text/fonts/fonts.factor b/basis/core-text/fonts/fonts.factor
index 5c57034632ea973d43a023f0e3a3d4e1ca2ce985..63b9a0f6e155e5670194e5a78181dde923660bb1 100644 (file)
--- a/basis/core-text/fonts/fonts.factor
+++ b/basis/core-text/fonts/fonts.factor
@@ -127,4 +127,4 @@ MEMO: (cache-font-metrics) ( font -- metrics )
 [
     \ (cache-font) reset-memoized
     \ (cache-font-metrics) reset-memoized
-] "core-text.fonts" add-init-hook
+] "core-text.fonts" add-startup-hook

diff --git a/basis/cpu/x86/features/features.factor b/basis/cpu/x86/features/features.factor
index b21aa762d861c078f29588d2ea02ffa3bbd259bd..38364805eb90215a362676f461ff34edd8384313 100644 (file)
--- a/basis/cpu/x86/features/features.factor
+++ b/basis/cpu/x86/features/features.factor
@@ -17,7 +17,7 @@ MEMO: sse-version ( -- n )
     sse_version
     "sse-version" get string>number [ min ] when* ;
 
-[ \ sse-version reset-memoized ] "cpu.x86.features" add-init-hook
+[ \ sse-version reset-memoized ] "cpu.x86.features" add-startup-hook
 
 : sse? ( -- ? ) sse-version 10 >= ;
 : sse2? ( -- ? ) sse-version 20 >= ;

diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index d78d05bac75c51d04cdec4a368768c099e28d230..86006f843ec11f57397d4f9d73222d5a1fa6b06f 100644 (file)
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -1413,7 +1413,7 @@ enable-fixnum-log2
             flush
             1 exit
         ] when
-    ] "cpu.x86" add-init-hook ;
+    ] "cpu.x86" add-startup-hook ;
 
 : enable-sse2 ( version -- )
     20 >= [

diff --git a/basis/environment/environment.factor b/basis/environment/environment.factor
index e60a52c995b94fb2613c4b272242ff1a88663a9c..ccdbd66d96c53f8fb35d797cd0a3b3256a08755c 100644 (file)
--- a/basis/environment/environment.factor
+++ b/basis/environment/environment.factor
@@ -32,4 +32,4 @@ HOOK: (set-os-envs) os ( seq -- )
         os windows? ";" ":" ? split
         [ add-vocab-root ] each
     ] when*    
-] "environment" add-init-hook
+] "environment" add-startup-hook

diff --git a/basis/game/input/input.factor b/basis/game/input/input.factor
index 954602cf0671e95894b41087d782877dd75eade1..261f19cb9e908689d869c9fa9a9f59238ab2f835 100755 (executable)
--- a/basis/game/input/input.factor
+++ b/basis/game/input/input.factor
@@ -35,7 +35,7 @@ M: f (reset-game-input) ;
 : reset-game-input ( -- )
     (reset-game-input) ;
 
-[ reset-game-input ] "game-input" add-init-hook
+[ reset-game-input ] "game-input" add-startup-hook
 
 PRIVATE>
 

diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor
index d4bfbb35c227f0a31e4de64ac256e51b81f751f1..cb20f78a3301c764436b386370b2da0190a5c6cd 100755 (executable)
--- a/basis/io/launcher/launcher.factor
+++ b/basis/io/launcher/launcher.factor
@@ -75,7 +75,7 @@ SYMBOL: wait-flag
 [
     H{ } clone processes set-global
     start-wait-thread
-] "io.launcher" add-init-hook
+] "io.launcher" add-startup-hook
 
 : process-started ( process handle -- )
     >>handle

diff --git a/basis/io/sockets/unix/unix.factor b/basis/io/sockets/unix/unix.factor
index 6bf62a034e586c075b719fb5fc78f165687d491b..71ad5a57582a91b7aa4866cc4497e01dc6a5953a 100755 (executable)
--- a/basis/io/sockets/unix/unix.factor
+++ b/basis/io/sockets/unix/unix.factor
@@ -117,7 +117,7 @@ SYMBOL: receive-buffer
 
 CONSTANT: packet-size 65536
 
-[ packet-size malloc receive-buffer set-global ] "io.sockets.unix" add-init-hook
+[ packet-size malloc &free receive-buffer set-global ] "io.sockets.unix" add-startup-hook
 
 :: do-receive ( port -- packet sockaddr )
     port addr>> empty-sockaddr/size :> ( sockaddr len )

diff --git a/basis/io/thread/thread.factor b/basis/io/thread/thread.factor
index 88db135f447c24975117ee9a579dddb384bae4a1..994dcd9c501f81d07dfe571f8a4b0f6f29432936 100644 (file)
--- a/basis/io/thread/thread.factor
+++ b/basis/io/thread/thread.factor
@@ -17,4 +17,4 @@ SYMBOL: io-thread-running?
 [\r
     t io-thread-running? set-global\r
     start-io-thread\r
-] "io.thread" add-init-hook\r
+] "io.thread" add-startup-hook\r

diff --git a/basis/logging/server/server.factor b/basis/logging/server/server.factor
index 848ad5d40e8d160b8001d780c4ff3e7b189b5e74..f5539b281325aeae295f86e3aa308bee4c254b12 100644 (file)
--- a/basis/logging/server/server.factor
+++ b/basis/logging/server/server.factor
@@ -106,4 +106,4 @@ CONSTANT: keep-logs 10
 [\r
     H{ } clone log-files set-global\r
     log-server\r
-] "logging" add-init-hook\r
+] "logging" add-startup-hook\r

diff --git a/basis/monotonic-clock/authors.txt b/basis/monotonic-clock/authors.txt
new file mode 100644 (file)
index 0000000..7c1b2f2
--- /dev/null
+++ b/basis/monotonic-clock/authors.txt
@@ -0,0 +1 @@
+Doug Coleman

diff --git a/basis/monotonic-clock/monotonic-clock-docs.factor b/basis/monotonic-clock/monotonic-clock-docs.factor
new file mode 100644 (file)
index 0000000..735dbca
--- /dev/null
+++ b/basis/monotonic-clock/monotonic-clock-docs.factor
@@ -0,0 +1,18 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel math ;
+IN: monotonic-clock
+
+HELP: monotonic-count
+{ $values
+    
+    { "n" integer }
+}
+{ $description "Returns a monotonically increasing number of nanoseconds since an arbitrary time. This number can be compared against future calls to " { $link monotonic-count } "." } ;
+
+ARTICLE: "monotonic-clock" "Monotonic clock"
+"The " { $vocab-link "monotonic-clock" } " vocabulary implements a single word which can be used as a clock. A special property of this clock is that it is independent of the system time and time zones." $nl
+"Get the number of nanoseconds since an arbitrary beginning:"
+{ $subsections monotonic-count } ;
+
+ABOUT: "monotonic-clock"

diff --git a/basis/monotonic-clock/monotonic-clock.factor b/basis/monotonic-clock/monotonic-clock.factor
new file mode 100755 (executable)
index 0000000..678c527
--- /dev/null
+++ b/basis/monotonic-clock/monotonic-clock.factor
@@ -0,0 +1,12 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators system vocabs.loader ;
+IN: monotonic-clock
+
+HOOK: monotonic-count os ( -- n )
+
+{
+    { [ os macosx? ] [ "monotonic-clock.unix.macosx" ] }
+    { [ os unix? ] [ "monotonic-clock.unix" ] }
+    { [ os windows? ] [ "monotonic-clock.windows" ] }
+} cond require

diff --git a/basis/monotonic-clock/unix/authors.txt b/basis/monotonic-clock/unix/authors.txt
new file mode 100644 (file)
index 0000000..7c1b2f2
--- /dev/null
+++ b/basis/monotonic-clock/unix/authors.txt
@@ -0,0 +1 @@
+Doug Coleman

diff --git a/basis/monotonic-clock/unix/macosx/authors.txt b/basis/monotonic-clock/unix/macosx/authors.txt
new file mode 100644 (file)
index 0000000..7c1b2f2
--- /dev/null
+++ b/basis/monotonic-clock/unix/macosx/authors.txt
@@ -0,0 +1 @@
+Doug Coleman

diff --git a/basis/monotonic-clock/unix/macosx/macosx.factor b/basis/monotonic-clock/unix/macosx/macosx.factor
new file mode 100755 (executable)
index 0000000..5bdb8ff
--- /dev/null
+++ b/basis/monotonic-clock/unix/macosx/macosx.factor
@@ -0,0 +1,24 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.syntax classes.struct kernel math
+monotonic-clock system unix.types ;
+IN: monotonic-clock.unix.macosx
+
+STRUCT: mach_timebase_info
+    { numer uint32_t }
+    { denom uint32_t } ;
+
+TYPEDEF: mach_timebase_info* mach_timebase_info_t
+TYPEDEF: mach_timebase_info mach_timebase_info_data_t
+
+FUNCTION: uint64_t mach_absolute_time ( ) ;
+FUNCTION: kern_return_t mach_timebase_info ( mach_timebase_info_t info ) ;
+FUNCTION: kern_return_t mach_wait_until ( uint64_t deadline ) ;
+
+ERROR: mach-timebase-info ret ;
+
+M: macosx monotonic-count 
+    mach_absolute_time
+    \ mach_timebase_info <struct> [
+        mach_timebase_info [ mach-timebase-info ] unless-zero
+    ] keep [ numer>> ] [ denom>> ] bi / * ;

diff --git a/basis/monotonic-clock/unix/macosx/tags.txt b/basis/monotonic-clock/unix/macosx/tags.txt
new file mode 100644 (file)
index 0000000..6bf6830
--- /dev/null
+++ b/basis/monotonic-clock/unix/macosx/tags.txt
@@ -0,0 +1 @@
+unportable

diff --git a/basis/monotonic-clock/unix/unix.factor b/basis/monotonic-clock/unix/unix.factor
new file mode 100644 (file)
index 0000000..d739735
--- /dev/null
+++ b/basis/monotonic-clock/unix/unix.factor
@@ -0,0 +1,22 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.syntax calendar.unix classes.struct
+kernel monotonic-clock system unix unix.time unix.types ;
+IN: monotonic-clock.unix
+
+LIBRARY: librt
+
+FUNCTION: int clock_settime ( clockid_t clock_id, timespec* tp ) ;
+FUNCTION: int clock_gettime ( clockid_t clock_id, timespec* tp ) ;
+FUNCTION: int clock_getres ( clockid_t clock_id, timespec* res ) ;
+
+CONSTANT: CLOCK_REALTIME 0
+CONSTANT: CLOCK_MONOTONIC 1
+CONSTANT: CLOCK_PROCESS_CPUTIME_ID 2
+CONSTANT: CLOCK_THREAD_CPUTIME_ID 3
+
+CONSTANT: TIMER_ABSTIME 1
+
+M: unix monotonic-count
+    CLOCK_MONOTONIC timespec <struct> [ clock_gettime io-error ] keep
+    timespec>nanoseconds ;

diff --git a/basis/monotonic-clock/windows/authors.txt b/basis/monotonic-clock/windows/authors.txt
new file mode 100644 (file)
index 0000000..7c1b2f2
--- /dev/null
+++ b/basis/monotonic-clock/windows/authors.txt
@@ -0,0 +1 @@
+Doug Coleman

diff --git a/basis/monotonic-clock/windows/tags.txt b/basis/monotonic-clock/windows/tags.txt
new file mode 100644 (file)
index 0000000..6bf6830
--- /dev/null
+++ b/basis/monotonic-clock/windows/tags.txt
@@ -0,0 +1 @@
+unportable

diff --git a/basis/monotonic-clock/windows/windows.factor b/basis/monotonic-clock/windows/windows.factor
new file mode 100755 (executable)
index 0000000..bb47941
--- /dev/null
+++ b/basis/monotonic-clock/windows/windows.factor
@@ -0,0 +1,20 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.data fry kernel monotonic-clock
+system windows.errors windows.kernel32 math ;
+IN: monotonic-clock.windows
+
+<PRIVATE
+
+: execute-performance-query ( word -- n )
+    [ "LARGE_INTEGER*" <c-object> ] dip
+    '[ _ execute win32-error=0/f ] keep *ulonglong ; inline
+
+PRIVATE>
+
+: cpu-frequency ( -- n )
+    \ QueryPerformanceFrequency execute-performance-query ;
+
+M: windows monotonic-count  ( -- n )
+    \ QueryPerformanceCounter execute-performance-query
+    1000000000 * cpu-frequency /i ;

diff --git a/basis/opengl/gl/extensions/extensions.factor b/basis/opengl/gl/extensions/extensions.factor
index 6292a683e3066d4e44d928cff397ceb2a27018c5..540fba40f0294d84173e03437001bab8702d8f4d 100644 (file)
--- a/basis/opengl/gl/extensions/extensions.factor
+++ b/basis/opengl/gl/extensions/extensions.factor
@@ -19,7 +19,7 @@ SYMBOL: +gl-function-pointers+
 : reset-gl-function-pointers ( -- )
     100 <hashtable> +gl-function-pointers+ set-global ;
     
-[ reset-gl-function-pointers ] "opengl.gl" add-init-hook
+[ reset-gl-function-pointers ] "opengl.gl" add-startup-hook
 reset-gl-function-pointers
 reset-gl-function-number-counter
 

diff --git a/basis/openssl/openssl.factor b/basis/openssl/openssl.factor
index 8f14c60e14abf4bda8766efc662bd932d5d43654..76806f9523c0151a1d0500ff17abbc6dbcb5c314 100644 (file)
--- a/basis/openssl/openssl.factor
+++ b/basis/openssl/openssl.factor
@@ -34,4 +34,4 @@ SYMBOL: ssl-initialized?
         t ssl-initialized? set-global
     ] unless ;
 
-[ f ssl-initialized? set-global ] "openssl" add-init-hook
+[ f ssl-initialized? set-global ] "openssl" add-startup-hook

diff --git a/basis/pango/cairo/cairo.factor b/basis/pango/cairo/cairo.factor
index 6fd8d57893183c9855b8a62acfed36ea752d2046..d6baaffe2e77da6557751c3b40d320e5ff6819e1 100644 (file)
--- a/basis/pango/cairo/cairo.factor
+++ b/basis/pango/cairo/cairo.factor
@@ -240,4 +240,4 @@ SYMBOL: cached-layouts
 : cached-line ( font string -- line )
     cached-layout layout>> first-line ;
 
-[ <cache-assoc> cached-layouts set-global ] "pango.cairo" add-init-hook
+[ <cache-assoc> cached-layouts set-global ] "pango.cairo" add-startup-hook

diff --git a/basis/pango/fonts/fonts.factor b/basis/pango/fonts/fonts.factor
index 280ddd20d6257881971dc915d05200bbe3ff9d8d..31a51e3f128013f8f6bac3a2bb2eb57c493464ba 100644 (file)
--- a/basis/pango/fonts/fonts.factor
+++ b/basis/pango/fonts/fonts.factor
@@ -111,4 +111,4 @@ MEMO: (cache-font-description) ( font -- description )
 : cache-font-description ( font -- description )
     strip-font-colors (cache-font-description) ;
 
-[ \ (cache-font-description) reset-memoized ] "pango.fonts" add-init-hook
+[ \ (cache-font-description) reset-memoized ] "pango.fonts" add-startup-hook

diff --git a/basis/random/mersenne-twister/mersenne-twister.factor b/basis/random/mersenne-twister/mersenne-twister.factor
index a0e40e5c382847d5b44a976b693b7097819fc8a6..90489d30521940781ef2c29e98c5a86dd9779247 100644 (file)
--- a/basis/random/mersenne-twister/mersenne-twister.factor
+++ b/basis/random/mersenne-twister/mersenne-twister.factor
@@ -79,5 +79,5 @@ M: mersenne-twister random-32* ( mt -- r )
 
 [
     default-mersenne-twister random-generator set-global
-] "bootstrap.random" add-init-hook
+] "bootstrap.random" add-startup-hook
 

diff --git a/basis/random/unix/unix.factor b/basis/random/unix/unix.factor
index 599cd5e0ad6b3cbc03e1015e3eac9c324935ef5b..fd93d6492cc73336460f934ad9a9ca2202cf2823 100644 (file)
--- a/basis/random/unix/unix.factor
+++ b/basis/random/unix/unix.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types io io.files kernel namespaces random
-io.encodings.binary init accessors system ;
+io.encodings.binary init accessors system destructors ;
 IN: random.unix
 
 TUPLE: unix-random reader ;
@@ -9,17 +9,19 @@ TUPLE: unix-random reader ;
 : <unix-random> ( path -- random )
     binary <file-reader> unix-random boa ;
 
+M: unix-random dispose reader>> dispose ;
+
 M: unix-random random-bytes* ( n tuple -- byte-array )
     reader>> stream-read ;
 
 os openbsd? [
     [
-        "/dev/srandom" <unix-random> secure-random-generator set-global
-        "/dev/arandom" <unix-random> system-random-generator set-global
-    ] "random.unix" add-init-hook
+        "/dev/srandom" <unix-random> &dispose secure-random-generator set-global
+        "/dev/arandom" <unix-random> &dispose system-random-generator set-global
+    ] "random.unix" add-startup-hook
 ] [
     [
-        "/dev/random" <unix-random> secure-random-generator set-global
-        "/dev/urandom" <unix-random> system-random-generator set-global
-    ] "random.unix" add-init-hook
+        "/dev/random" <unix-random> &dispose secure-random-generator set-global
+        "/dev/urandom" <unix-random> &dispose system-random-generator set-global
+    ] "random.unix" add-startup-hook
 ] if

diff --git a/basis/random/windows/windows.factor b/basis/random/windows/windows.factor
index d959b191c9993170f017167e9f031332992b3c16..a518a6e39af523a994b275fa98045ca7cff6fae2 100644 (file)
--- a/basis/random/windows/windows.factor
+++ b/basis/random/windows/windows.factor
@@ -4,7 +4,7 @@ locals namespaces random windows.advapi32 windows.errors
 windows.kernel32 math.bitwise ;
 IN: random.windows
 
-TUPLE: windows-rng provider type ;
+TUPLE: windows-rng < disposable provider type ;
 C: <windows-rng> windows-rng
 
 TUPLE: windows-crypto-context handle ;
@@ -65,5 +65,11 @@ M: windows-rng random-bytes* ( n tuple -- bytes )
     [ MS_STRONG_PROV PROV_RSA_FULL <windows-rng> ]
     [ drop MS_ENH_RSA_AES_PROV PROV_RSA_AES <windows-rng> ] recover
     secure-random-generator set-global
+] "random.windows" add-startup-hook
 
-] "random.windows" add-init-hook
+[
+    [
+        ! system-random-generator get-global &dispose drop
+        ! secure-random-generator get-global &dispose drop
+    ] with-destructors
+] "random.windows" add-shutdown-hook

diff --git a/basis/threads/threads-docs.factor b/basis/threads/threads-docs.factor
index 8956051b251fd27634aeef7aeef4b40b8b3426e0..85952ccd911f38d93bcaf7788f19b09b5a474775 100644 (file)
--- a/basis/threads/threads-docs.factor
+++ b/basis/threads/threads-docs.factor
@@ -16,7 +16,7 @@ ARTICLE: "threads-start/stop" "Starting and stopping threads"
 }
 "Threads stop either when the quotation given to " { $link spawn } " returns, or when the following word is called:"
 { $subsections stop }
-"If the image is saved and started again, all runnable threads are stopped. Vocabularies wishing to have a background thread always running should use " { $link add-init-hook } "." ;
+"If the image is saved and started again, all runnable threads are stopped. Vocabularies wishing to have a background thread always running should use " { $link add-startup-hook } "." ;
 
 ARTICLE: "threads-yield" "Yielding and suspending threads"
 "Yielding to other threads:"

diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor
index dec44625f72a74b10a023942b46fcc9cabc5183f..b7e0e1b87f1e8f9ed275d15b1d2673e712a5b0b9 100644 (file)
--- a/basis/threads/threads.factor
+++ b/basis/threads/threads.factor
@@ -225,4 +225,4 @@ GENERIC: error-in-thread ( error thread -- )
 
 PRIVATE>
 
-[ init-threads ] "threads" add-init-hook
+[ init-threads ] "threads" add-startup-hook

diff --git a/basis/tools/crossref/crossref.factor b/basis/tools/crossref/crossref.factor
index 90fe7e8e9daee1a6715b8b55c2a56f066e1b8804..134395f1a85881e02a047c8f90f2fd3e8fa9659f 100644 (file)
--- a/basis/tools/crossref/crossref.factor
+++ b/basis/tools/crossref/crossref.factor
@@ -135,6 +135,6 @@ SINGLETON: invalidate-crossref
 
 M: invalidate-crossref definitions-changed 2drop crossref global delete-at ;
 
-[ invalidate-crossref add-definition-observer ] "tools.crossref" add-init-hook
+[ invalidate-crossref add-definition-observer ] "tools.crossref" add-startup-hook
 
 PRIVATE>

diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor
index 856b99fd98ebae6729c7e7d6b4d9ed61a8afb96c..c79065bb29b17baf8ca449199c5e62f8b19cb44f 100755 (executable)
--- a/basis/tools/deploy/shaker/shaker.factor
+++ b/basis/tools/deploy/shaker/shaker.factor
@@ -24,9 +24,9 @@ IN: tools.deploy.shaker
 
 : add-command-line-hook ( -- )
     [ (command-line) command-line set-global ] "command-line"
-    init-hooks get set-at ;
+    startup-hooks get set-at ;
 
-: strip-init-hooks ( -- )
+: strip-startup-hooks ( -- )
     "Stripping startup hooks" show
     {
         "alien.strings"
@@ -35,17 +35,17 @@ IN: tools.deploy.shaker
         "environment"
         "libc"
     }
-    [ init-hooks get delete-at ] each
+    [ startup-hooks get delete-at ] each
     deploy-threads? get [
-        "threads" init-hooks get delete-at
+        "threads" startup-hooks get delete-at
     ] unless
     native-io? [
-        "io.thread" init-hooks get delete-at
+        "io.thread" startup-hooks get delete-at
     ] unless
     strip-io? [
-        "io.files" init-hooks get delete-at
-        "io.backend" init-hooks get delete-at
-        "io.thread" init-hooks get delete-at
+        "io.files" startup-hooks get delete-at
+        "io.backend" startup-hooks get delete-at
+        "io.thread" startup-hooks get delete-at
     ] when
     strip-dictionary? [
         {
@@ -53,7 +53,7 @@ IN: tools.deploy.shaker
             "vocabs"
             "vocabs.cache"
             "source-files.errors"
-        } [ init-hooks get delete-at ] each
+        } [ startup-hooks get delete-at ] each
     ] when ;
 
 : strip-debugger ( -- )
@@ -294,7 +294,7 @@ IN: tools.deploy.shaker
             continuations:error-continuation
             continuations:error-thread
             continuations:restarts
-            init:init-hooks
+            init:startup-hooks
             source-files:source-files
             input-stream
             output-stream
@@ -449,7 +449,7 @@ SYMBOL: deploy-vocab
 : deploy-boot-quot ( word -- )
     [
         [ boot ] %
-        init-hooks get values concat %
+        startup-hooks get values concat %
         strip-debugger? [ , ] [
             ! Don't reference 'try' directly since we don't want
             ! to pull in the debugger and prettyprinter into every
@@ -468,7 +468,7 @@ SYMBOL: deploy-vocab
     ] [ ] make
     set-boot-quot ;
 
-: init-stripper ( -- )
+: startup-stripper ( -- )
     t "quiet" set-global
     f output-stream set-global ;
 
@@ -507,7 +507,7 @@ SYMBOL: deploy-vocab
     [ clear-megamorphic-cache ] each ;
 
 : strip ( -- )
-    init-stripper
+    startup-stripper
     strip-libc
     strip-destructors
     strip-call
@@ -515,7 +515,7 @@ SYMBOL: deploy-vocab
     strip-debugger
     strip-specialized-arrays
     compute-next-methods
-    strip-init-hooks
+    strip-startup-hooks
     add-command-line-hook
     strip-c-io
     strip-default-methods

diff --git a/basis/tools/deploy/shaker/strip-cocoa.factor b/basis/tools/deploy/shaker/strip-cocoa.factor
index 133308b7329858a4f26656c6cce3d7933e5a7efb..d5c5bd54da5d5692a529f8ca2da9b0249279713f 100644 (file)
--- a/basis/tools/deploy/shaker/strip-cocoa.factor
+++ b/basis/tools/deploy/shaker/strip-cocoa.factor
@@ -17,7 +17,7 @@ IN: cocoa.application
 
 : objc-error ( error -- ) die ;
 
-[ [ die ] 19 setenv ] "cocoa.application" add-init-hook
+[ [ die ] 19 setenv ] "cocoa.application" add-startup-hook
 
 H{ } clone \ pool [
     global [
@@ -46,4 +46,4 @@ H{ } clone \ pool [
 \ make-prepare-send reset-memoized
 \ <selector> reset-memoized
 
-\ (send) def>> second clear-assoc
\ No newline at end of file
+\ (send) def>> second clear-assoc

diff --git a/basis/tools/deprecation/deprecation.factor b/basis/tools/deprecation/deprecation.factor
index 0ee60b06b5168c471797c88d562012a47169c4dc..8dbfda3011204cf9a06bfebfb0a6eac7dea3e808 100644 (file)
--- a/basis/tools/deprecation/deprecation.factor
+++ b/basis/tools/deprecation/deprecation.factor
@@ -73,6 +73,6 @@ M: deprecation-observer definitions-changed
     [ drop initialize-deprecation-notes ] if ;
 
 [ \ deprecation-observer add-definition-observer ] 
-"tools.deprecation" add-init-hook
+"tools.deprecation" add-startup-hook
 
 initialize-deprecation-notes

diff --git a/basis/tools/errors/model/model.factor b/basis/tools/errors/model/model.factor
index c874363fe68f49f449ecfb7f6e0894567cb14c27..b41d236fd7b89a36e0bf5bf2640f82cb43250776 100644 (file)
--- a/basis/tools/errors/model/model.factor
+++ b/basis/tools/errors/model/model.factor
@@ -14,5 +14,5 @@ SINGLETON: updater
 
 M: updater errors-changed drop f (error-list-model) get-global set-model ;
 
-[ updater add-error-observer ] "ui.tools.error-list" add-init-hook
+[ updater add-error-observer ] "ui.tools.error-list" add-startup-hook
 

diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor
index 9759dbfcc55f36e868851e12687c3c8e80f3facc..8eeca89c2f14903c396d40e4abbd673eee0e17ad 100755 (executable)
--- a/basis/ui/backend/cocoa/cocoa.factor
+++ b/basis/ui/backend/cocoa/cocoa.factor
@@ -225,9 +225,9 @@ CLASS: {
 : install-app-delegate ( -- )
     NSApp FactorApplicationDelegate install-delegate ;
 
-SYMBOL: cocoa-init-hook
+SYMBOL: cocoa-startup-hook
 
-cocoa-init-hook [
+cocoa-startup-hook [
     [ "MiniFactor.nib" load-nib install-app-delegate ]
 ] initialize
 
@@ -235,7 +235,7 @@ M: cocoa-ui-backend (with-ui)
     "UI" assert.app [
         [
             init-clipboard
-            cocoa-init-hook get call( -- )
+            cocoa-startup-hook get call( -- )
             start-ui
             f io-thread-running? set-global
             init-thread-timer

diff --git a/basis/ui/backend/cocoa/tools/tools.factor b/basis/ui/backend/cocoa/tools/tools.factor
index d04bcededac38e52d8f0fe4f4dff7b091523cdb5..00c1ad35831b3cbf639eb60daa864e574076f9d3 100644 (file)
--- a/basis/ui/backend/cocoa/tools/tools.factor
+++ b/basis/ui/backend/cocoa/tools/tools.factor
@@ -101,4 +101,4 @@ FUNCTION: void NSUpdateDynamicServices ;
     install-app-delegate
     "Factor.nib" load-nib
     register-services
-] cocoa-init-hook set-global
+] cocoa-startup-hook set-global

diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor
index 8e982f8e4596e7322d361117997989fe878aff98..2f1de2f5c6e583f147c3fdc3665c97c317d8d6c5 100644 (file)
--- a/basis/ui/gestures/gestures.factor
+++ b/basis/ui/gestures/gestures.factor
@@ -184,7 +184,7 @@ SYMBOL: drag-timer
 : start-drag-timer ( -- )
     hand-buttons get-global empty? [
         [ drag-gesture ]
-        300 milliseconds hence
+        300 milliseconds
         100 milliseconds
         add-alarm drag-timer get-global >box
     ] when ;

diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor
index 6de303089efcde3e71f1ed38f1e18999e2090660..8260608cd4cb40ccb492cc1bd464ce5010264945 100644 (file)
--- a/basis/ui/ui.factor
+++ b/basis/ui/ui.factor
@@ -236,7 +236,7 @@ M: object close-window
 [
     f \ ui-running set-global
     <flag> ui-notify-flag set-global
-] "ui" add-init-hook
+] "ui" add-startup-hook
 
 : with-ui ( quot -- )
     ui-running? [ call( -- ) ] [ '[ init-ui @ ] (with-ui) ] if ;

diff --git a/basis/vocabs/cache/cache.factor b/basis/vocabs/cache/cache.factor
index 24ccd391f19dd00d4d93edee04cc4f3254f40cd6..1f62f02ddee23d0924f6231efc06309bf5abf67c 100644 (file)
--- a/basis/vocabs/cache/cache.factor
+++ b/basis/vocabs/cache/cache.factor
@@ -18,4 +18,4 @@ M: cache-observer vocabs-changed drop reset-cache ;
 [
     f changed-vocabs set-global
     cache-observer add-vocab-observer
-] "vocabs.cache" add-init-hook
\ No newline at end of file
+] "vocabs.cache" add-startup-hook

diff --git a/basis/vocabs/refresh/monitor/monitor.factor b/basis/vocabs/refresh/monitor/monitor.factor
index 1445b9f882e8788902a6ac15e6044b284a1a69e6..1bf73862e6b58b0da3dcff4cbe08a0c22d331df0 100644 (file)
--- a/basis/vocabs/refresh/monitor/monitor.factor
+++ b/basis/vocabs/refresh/monitor/monitor.factor
@@ -56,4 +56,4 @@ TR: convert-separators "/\\" ".." ;
 [\r
     "-no-monitors" (command-line) member?\r
     [ start-monitor-thread ] unless\r
-] "vocabs.refresh.monitor" add-init-hook\r
+] "vocabs.refresh.monitor" add-startup-hook\r

diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor
index 39f5ce1dad71753051489e3900164c4adf4d042e..696902439ca7f9d075d29c6f5732594ad0cb37fc 100755 (executable)
--- a/basis/windows/com/wrapper/wrapper.factor
+++ b/basis/windows/com/wrapper/wrapper.factor
@@ -141,11 +141,11 @@ unless
     dup callbacks>> (callbacks>vtbls) >>vtbls
     f >>disposed drop ;
 
-: (init-hook) ( -- )
+: com-startup-hook ( -- )
     +live-wrappers+ get-global [ (allocate-wrapper) ] each
     H{ } +wrapped-objects+ set-global ;
 
-[ (init-hook) ] "windows.com.wrapper" add-init-hook
+[ com-startup-hook ] "windows.com.wrapper" add-startup-hook
 
 PRIVATE>
 

diff --git a/basis/windows/dinput/constants/constants.factor b/basis/windows/dinput/constants/constants.factor
index adbf29dfdd90099dceb74a69d12ab5d46d33929a..4e97cb0e01e058d9c78766e013305ce94a9b82f5 100755 (executable)
--- a/basis/windows/dinput/constants/constants.factor
+++ b/basis/windows/dinput/constants/constants.factor
@@ -831,7 +831,7 @@ M: array array-base-type first ;
     define-guid-constants
     define-format-constants ;
 
-[ define-constants ] "windows.dinput.constants" add-init-hook
+[ define-constants ] "windows.dinput.constants" add-startup-hook
 
 : uninitialize ( variable quot -- )
     '[ _ when* f ] change-global ; inline

diff --git a/basis/windows/fonts/fonts.factor b/basis/windows/fonts/fonts.factor
index 9e113e8c3b678d359329f011d4b4d5c11e368cbc..65a08ce3c7e7fa35db00ecf14fbc8e3965614b6e 100755 (executable)
--- a/basis/windows/fonts/fonts.factor
+++ b/basis/windows/fonts/fonts.factor
@@ -37,7 +37,7 @@ MEMO:: (cache-font) ( font -- HFONT )
 
 : cache-font ( font -- HFONT ) strip-font-colors (cache-font) ;
 
-[ \ (cache-font) reset-memoized ] "windows.fonts" add-init-hook
+[ \ (cache-font) reset-memoized ] "windows.fonts" add-startup-hook
 
 : TEXTMETRIC>metrics ( TEXTMETRIC -- metrics )
     [ metrics new 0 >>width ] dip {

diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor
index 9555927ab1b0f0e5b68844ad73f9e378b86b2b8d..87540dc24f7b050124f7829a32ab5b99342a9bd7 100755 (executable)
--- a/basis/windows/uniscribe/uniscribe.factor
+++ b/basis/windows/uniscribe/uniscribe.factor
@@ -113,5 +113,5 @@ SYMBOL: cached-script-strings
 : cached-script-string ( font string -- script-string )
     cached-script-strings get-global [ <script-string> ] 2cache ;
 
-[ <cache-assoc> cached-script-strings set-global ]
-"windows.uniscribe" add-init-hook
+[ <cache-assoc> &dispose cached-script-strings set-global ]
+"windows.uniscribe" add-startup-hook

diff --git a/basis/windows/winsock/winsock.factor b/basis/windows/winsock/winsock.factor
index 7bd86c8e47e14fb65c4845306a159dba517ec602..b8d1f099d20ce7bc6db9fb9e17a26372fb9dbfdb 100755 (executable)
--- a/basis/windows/winsock/winsock.factor
+++ b/basis/windows/winsock/winsock.factor
@@ -442,4 +442,7 @@ CONSTANT: WSAID_CONNECTEX GUID: {25a207b9-ddf3-4660-8ee9-76e58c74063e}
 : init-winsock ( -- )
     HEX: 0202 <wsadata> WSAStartup winsock-return-check ;
 
-[ init-winsock ] "windows.winsock" add-init-hook
+: shutdown-winsock ( -- ) WSACleanup winsock-return-check ;
+
+[ init-winsock ] "windows.winsock" add-startup-hook
+[ shutdown-winsock ] "windows.winsock" add-shutdown-hook

diff --git a/core/alien/alien.factor b/core/alien/alien.factor
index f008a4bd599ace290acf22c8b771c2e12b656b94..91dd150e8f14f0924754fb57ae64e640734bc763 100644 (file)
--- a/core/alien/alien.factor
+++ b/core/alien/alien.factor
@@ -63,7 +63,7 @@ ERROR: alien-invoke-error library symbol ;
 ! cleared on startup.
 SYMBOL: callbacks
 
-[ H{ } clone callbacks set-global ] "alien" add-init-hook
+[ H{ } clone callbacks set-global ] "alien" add-startup-hook
 
 <PRIVATE
 

diff --git a/core/alien/strings/strings.factor b/core/alien/strings/strings.factor
index 83758cd8666ab53a047bc5f9784203feb0068e7f..8e09fa8c2c24ea6b9563d37be834d49602c5df7f 100644 (file)
--- a/core/alien/strings/strings.factor
+++ b/core/alien/strings/strings.factor
@@ -69,5 +69,4 @@ M: sequence string>symbol [ string>symbol* ] map ;
 [
     8 getenv utf8 alien>string string>cpu \ cpu set-global
     9 getenv utf8 alien>string string>os \ os set-global
-] "alien.strings" add-init-hook
-
+] "alien.strings" add-startup-hook

diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index ae668ed54fe614529323d2e5285c42ecf78b4b97..ca9056805e18bf364ee63827598c36560a527a8d 100644 (file)
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -429,7 +429,7 @@ tuple
     { "set-datastack" "kernel" (( ds -- )) }
     { "set-retainstack" "kernel" (( rs -- )) }
     { "set-callstack" "kernel" (( cs -- )) }
-    { "exit" "system" (( n -- )) }
+    { "(exit)" "system" (( n -- )) }
     { "data-room" "memory" (( -- data-room )) }
     { "code-room" "memory" (( -- code-room )) }
     { "micros" "system" (( -- us )) }

diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor
index 88434cef55f689688589fe0ce6f8467553564beb..29d0a311a311eb5928549d0e9eacfae948c5e2cb 100644 (file)
--- a/core/bootstrap/stage1.factor
+++ b/core/bootstrap/stage1.factor
@@ -3,7 +3,7 @@
 USING: arrays assocs continuations debugger generic hashtables
 init io io.files kernel kernel.private make math memory
 namespaces parser prettyprint sequences splitting system
-vectors vocabs vocabs.loader words ;
+vectors vocabs vocabs.loader words destructors ;
 QUALIFIED: bootstrap.image.private
 IN: bootstrap.stage1
 
@@ -37,12 +37,12 @@ load-help? off
     [
         "resource:basis/bootstrap/stage2.factor"
         dup exists? [
-            run-file
+            [ run-file ] with-destructors
         ] [
             "Cannot find " write write "." print
             "Please move " write image write " to the same directory as the Factor sources," print
             "and try again." print
-            1 exit
+            1 (exit)
         ] if
     ] %
 ] [ ] make

diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor
index 9ffb98a383b2bbeabaa993a7d42112d1b3c66975..bc372d8d90c9df66b873e7b4a5d7e3217dfa6dec 100644 (file)
--- a/core/compiler/units/units.factor
+++ b/core/compiler/units/units.factor
@@ -81,11 +81,11 @@ SYMBOL: definition-observers
 GENERIC: definitions-changed ( assoc obj -- )
 
 [ V{ } clone definition-observers set-global ]
-"compiler.units" add-init-hook
+"compiler.units" add-startup-hook
 
 ! This goes here because vocabs cannot depend on init
 [ V{ } clone vocab-observers set-global ]
-"vocabs" add-init-hook
+"vocabs" add-startup-hook
 
 : add-definition-observer ( obj -- )
     definition-observers get push ;

diff --git a/core/destructors/destructors.factor b/core/destructors/destructors.factor
index 8cceeefdce9df8c6a150117685ed3298dca5c672..577da7c4eb778ea2f566ebf6c91a496284c6161d 100644 (file)
--- a/core/destructors/destructors.factor
+++ b/core/destructors/destructors.factor
@@ -6,7 +6,7 @@ IN: destructors
 
 SYMBOL: disposables
 
-[ H{ } clone disposables set-global ] "destructors" add-init-hook
+[ H{ } clone disposables set-global ] "destructors" add-startup-hook
 
 ERROR: already-unregistered disposable ;
 
@@ -87,3 +87,8 @@ PRIVATE>
         [ do-error-destructors ]
         cleanup
     ] with-scope ; inline
+
+[
+    always-destructors get-global
+    error-destructors get-global append dispose-each
+] "destructors.global" add-shutdown-hook

diff --git a/core/init/init-docs.factor b/core/init/init-docs.factor
index e76b6e8fee053d8e7a3ceb2f9570ed64716c7988..edee683bded8ca8191e997eb3b09d6ccbc1016cf 100644 (file)
--- a/core/init/init-docs.factor
+++ b/core/init/init-docs.factor
@@ -15,29 +15,39 @@ HELP: set-boot-quot
 { $description "Sets the initial quotation called by the VM on startup. This quotation must begin with a call to " { $link boot } ". The image must be saved for changes to the boot quotation to take effect." }
 { $notes "The " { $link "tools.deploy" } " tool uses this word." } ;
 
-HELP: init-hooks
+HELP: startup-hooks
 { $var-description "An association list mapping string identifiers to quotations to be run on startup." } ;
 
-HELP: do-init-hooks
+HELP: shutdown-hooks
+{ $var-description "An association list mapping string identifiers to quotations to be run on shutdown." } ;
+
+HELP: do-startup-hooks
 { $description "Calls all initialization hook quotations." } ;
 
-HELP: add-init-hook
+HELP: do-shutdown-hooks
+{ $description "Calls all shutdown hook quotations." } ;
+
+HELP: add-startup-hook
 { $values { "quot" quotation } { "name" string } }
 { $description "Registers a startup hook. The hook will always run when Factor is started. If the hook was not already defined, this word also calls it immediately." } ;
 
-{ init-hooks do-init-hooks add-init-hook } related-words
+{ startup-hooks do-startup-hooks add-startup-hook add-shutdown-hook do-shutdown-hooks shutdown-hooks } related-words
 
 ARTICLE: "init" "Initialization and startup"
 "When Factor starts, the first thing it does is call a word:"
 { $subsections boot }
 "Next, initialization hooks are called:"
-{ $subsections do-init-hooks }
+{ $subsections do-startup-hooks }
 "Initialization hooks can be defined:"
-{ $subsections add-init-hook }
+{ $subsections add-startup-hook }
+"Corresponding shutdown hooks may also be defined:"
+{ $subsections add-shutdown-hook }
 "The boot quotation can be changed:"
 { $subsections
     boot-quot
     set-boot-quot
-} ;
+}
+"When quitting Factor, shutdown hooks are called:"
+{ $subsection do-shutdown-hooks } ;
 
 ABOUT: "init"

diff --git a/core/init/init.factor b/core/init/init.factor
index 5d8e88b85f5b2ee4a78109e618f868d8773cf913..16a39bbc21cfbb6d0857611ffbba6948cf99894b 100644 (file)
--- a/core/init/init.factor
+++ b/core/init/init.factor
@@ -4,19 +4,35 @@ USING: continuations continuations.private kernel
 kernel.private sequences assocs namespaces namespaces.private ;
 IN: init
 
-SYMBOL: init-hooks
+SYMBOL: startup-hooks
+SYMBOL: shutdown-hooks
 
-init-hooks global [ drop V{ } clone ] cache drop
+startup-hooks global [ drop V{ } clone ] cache drop
+shutdown-hooks global [ drop V{ } clone ] cache drop
 
-: do-init-hooks ( -- )
-    init-hooks get [ nip call( -- ) ] assoc-each ;
+: do-hooks ( symbol -- )
+    get [ nip call( -- ) ] assoc-each ;
 
-: add-init-hook ( quot name -- )
-    dup init-hooks get at [ over call( -- ) ] unless
-    init-hooks get set-at ;
+: do-startup-hooks ( -- ) startup-hooks do-hooks ;
+
+: do-shutdown-hooks ( -- ) shutdown-hooks do-hooks ;
+
+: add-startup-hook ( quot name -- )
+    startup-hooks get
+    [ at [ drop ] [ call( -- ) ] if ]
+    [ set-at ] 3bi ;
+
+: add-shutdown-hook ( quot name -- )
+    shutdown-hooks get set-at ;
 
 : boot ( -- ) init-namespaces init-catchstack init-error-handler ;
 
 : boot-quot ( -- quot ) 20 getenv ;
 
 : set-boot-quot ( quot -- ) 20 setenv ;
+
+: shutdown-quot ( -- quot ) 67 getenv ;
+
+: set-shutdown-quot ( quot -- ) 67 setenv ;
+
+[ do-shutdown-hooks ] set-shutdown-quot

diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor
index 494ccbff22853c73eb35ef983894ddf5ee846135..ee50500754cb329f7b4c75c3229ef32f20b03c56 100644 (file)
--- a/core/io/backend/backend.factor
+++ b/core/io/backend/backend.factor
@@ -29,9 +29,9 @@ M: object normalize-directory normalize-path ;
 
 : set-io-backend ( io-backend -- )
     io-backend set-global init-io init-stdio
-    "io.files" init-hooks get at call( -- ) ;
+    "io.files" startup-hooks get at call( -- ) ;
 
 ! Note that we have 'alien' in our using list so that the alien
 ! init hook runs before this one.
 [ init-io embedded? [ init-stdio ] unless ]
-"io.backend" add-init-hook
+"io.backend" add-startup-hook

diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index 6779c6d09429bc14bc4d055354a2ed709e59bf22..9824fba18cdcb49c3cd1a903f12aaa44b3b38959 100644 (file)
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -60,4 +60,4 @@ PRIVATE>
     13 getenv alien>native-string cwd prepend-path \ image set-global
     14 getenv alien>native-string cwd prepend-path \ vm set-global
     image parent-directory "resource-path" set-global
-] "io.files" add-init-hook
+] "io.files" add-startup-hook

diff --git a/core/source-files/errors/errors.factor b/core/source-files/errors/errors.factor
index ebacc90f633c7b906bc9447847b9520630e94134..4f5473ce9de921869ee2e94e7245102c19d90943 100644 (file)
--- a/core/source-files/errors/errors.factor
+++ b/core/source-files/errors/errors.factor
@@ -68,7 +68,7 @@ GENERIC: errors-changed ( observer -- )
 
 SYMBOL: error-observers
 
-[ V{ } clone error-observers set-global ] "source-files.errors" add-init-hook
+[ V{ } clone error-observers set-global ] "source-files.errors" add-startup-hook
 
 : add-error-observer ( observer -- ) error-observers get push ;
 

diff --git a/core/system/system.factor b/core/system/system.factor
index 38b4a5fd9bb5d9473d093856e31aa78edff8ef7b..5ee10374fc7253c8f34c71831217731cfc0061a7 100644 (file)
--- a/core/system/system.factor
+++ b/core/system/system.factor
@@ -56,3 +56,5 @@ PRIVATE>
 : embedded? ( -- ? ) 15 getenv ;
 
 : millis ( -- ms ) micros 1000 /i ;
+
+: exit ( n -- ) do-shutdown-hooks (exit) ;

diff --git a/extra/io/serial/unix/termios/bsd/bsd.factor b/extra/io/serial/unix/termios/bsd/bsd.factor
index 1d1e217ba0ce9ee9102749da0c1366fcd8e6b49d..172786126914ed5e37c54c1add614a6ce03964f0 100644 (file)
--- a/extra/io/serial/unix/termios/bsd/bsd.factor
+++ b/extra/io/serial/unix/termios/bsd/bsd.factor
@@ -1,6 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax classes.struct kernel sequences system ;
+USING: alien.c-types alien.syntax classes.struct kernel
+sequences system ;
 IN: io.serial.unix.termios
 
 CONSTANT: NCCS 20

diff --git a/extra/io/serial/unix/termios/linux/linux.factor b/extra/io/serial/unix/termios/linux/linux.factor
index c48bf9153f567ddab30132583a52be4f2de9f45c..1e9dce49c7174248846dfe570b2e31dd2cfaa4d8 100644 (file)
--- a/extra/io/serial/unix/termios/linux/linux.factor
+++ b/extra/io/serial/unix/termios/linux/linux.factor
@@ -1,6 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.syntax classes.struct kernel system unix ;
+USING: alien.c-types alien.syntax classes.struct kernel system
+unix ;
 IN: io.serial.unix.termios
 
 CONSTANT: NCCS 32

diff --git a/extra/monotonic-clock/authors.txt b/extra/monotonic-clock/authors.txt
deleted file mode 100644 (file)
index 7c1b2f2..0000000
--- a/extra/monotonic-clock/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Doug Coleman

diff --git a/extra/monotonic-clock/monotonic-clock.factor b/extra/monotonic-clock/monotonic-clock.factor
deleted file mode 100755 (executable)
index 8f277fb..0000000
--- a/extra/monotonic-clock/monotonic-clock.factor
+++ /dev/null
@@ -1,12 +0,0 @@
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: combinators system vocabs.loader ;
-IN: monotonic-clock
-
-HOOK: monotonic-count os ( -- n )
-
-{
-    { [ os unix? ] [ "monotonic-clock.unix" ] }
-    { [ os windows? ] [ "monotonic-clock.windows" ] }
-    { [ os macosx? ] [ "monotonic-clock.unix.macosx" ] }
-} cond require

diff --git a/extra/monotonic-clock/unix/authors.txt b/extra/monotonic-clock/unix/authors.txt
deleted file mode 100644 (file)
index 7c1b2f2..0000000
--- a/extra/monotonic-clock/unix/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Doug Coleman

diff --git a/extra/monotonic-clock/unix/macosx/authors.txt b/extra/monotonic-clock/unix/macosx/authors.txt
deleted file mode 100644 (file)
index 7c1b2f2..0000000
--- a/extra/monotonic-clock/unix/macosx/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Doug Coleman

diff --git a/extra/monotonic-clock/unix/macosx/macosx.factor b/extra/monotonic-clock/unix/macosx/macosx.factor
deleted file mode 100755 (executable)
index 5bdb8ff..0000000
--- a/extra/monotonic-clock/unix/macosx/macosx.factor
+++ /dev/null
@@ -1,24 +0,0 @@
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.syntax classes.struct kernel math
-monotonic-clock system unix.types ;
-IN: monotonic-clock.unix.macosx
-
-STRUCT: mach_timebase_info
-    { numer uint32_t }
-    { denom uint32_t } ;
-
-TYPEDEF: mach_timebase_info* mach_timebase_info_t
-TYPEDEF: mach_timebase_info mach_timebase_info_data_t
-
-FUNCTION: uint64_t mach_absolute_time ( ) ;
-FUNCTION: kern_return_t mach_timebase_info ( mach_timebase_info_t info ) ;
-FUNCTION: kern_return_t mach_wait_until ( uint64_t deadline ) ;
-
-ERROR: mach-timebase-info ret ;
-
-M: macosx monotonic-count 
-    mach_absolute_time
-    \ mach_timebase_info <struct> [
-        mach_timebase_info [ mach-timebase-info ] unless-zero
-    ] keep [ numer>> ] [ denom>> ] bi / * ;

diff --git a/extra/monotonic-clock/unix/macosx/tags.txt b/extra/monotonic-clock/unix/macosx/tags.txt
deleted file mode 100644 (file)
index 6bf6830..0000000
--- a/extra/monotonic-clock/unix/macosx/tags.txt
+++ /dev/null
@@ -1 +0,0 @@
-unportable

diff --git a/extra/monotonic-clock/unix/unix.factor b/extra/monotonic-clock/unix/unix.factor
deleted file mode 100644 (file)
index d739735..0000000
--- a/extra/monotonic-clock/unix/unix.factor
+++ /dev/null
@@ -1,22 +0,0 @@
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.syntax calendar.unix classes.struct
-kernel monotonic-clock system unix unix.time unix.types ;
-IN: monotonic-clock.unix
-
-LIBRARY: librt
-
-FUNCTION: int clock_settime ( clockid_t clock_id, timespec* tp ) ;
-FUNCTION: int clock_gettime ( clockid_t clock_id, timespec* tp ) ;
-FUNCTION: int clock_getres ( clockid_t clock_id, timespec* res ) ;
-
-CONSTANT: CLOCK_REALTIME 0
-CONSTANT: CLOCK_MONOTONIC 1
-CONSTANT: CLOCK_PROCESS_CPUTIME_ID 2
-CONSTANT: CLOCK_THREAD_CPUTIME_ID 3
-
-CONSTANT: TIMER_ABSTIME 1
-
-M: unix monotonic-count
-    CLOCK_MONOTONIC timespec <struct> [ clock_gettime io-error ] keep
-    timespec>nanoseconds ;

diff --git a/extra/monotonic-clock/windows/authors.txt b/extra/monotonic-clock/windows/authors.txt
deleted file mode 100644 (file)
index 7c1b2f2..0000000
--- a/extra/monotonic-clock/windows/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Doug Coleman

diff --git a/extra/monotonic-clock/windows/tags.txt b/extra/monotonic-clock/windows/tags.txt
deleted file mode 100644 (file)
index 6bf6830..0000000
--- a/extra/monotonic-clock/windows/tags.txt
+++ /dev/null
@@ -1 +0,0 @@
-unportable

diff --git a/extra/monotonic-clock/windows/windows.factor b/extra/monotonic-clock/windows/windows.factor
deleted file mode 100755 (executable)
index bb47941..0000000
--- a/extra/monotonic-clock/windows/windows.factor
+++ /dev/null
@@ -1,20 +0,0 @@
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.data fry kernel monotonic-clock
-system windows.errors windows.kernel32 math ;
-IN: monotonic-clock.windows
-
-<PRIVATE
-
-: execute-performance-query ( word -- n )
-    [ "LARGE_INTEGER*" <c-object> ] dip
-    '[ _ execute win32-error=0/f ] keep *ulonglong ; inline
-
-PRIVATE>
-
-: cpu-frequency ( -- n )
-    \ QueryPerformanceFrequency execute-performance-query ;
-
-M: windows monotonic-count  ( -- n )
-    \ QueryPerformanceCounter execute-performance-query
-    1000000000 * cpu-frequency /i ;

diff --git a/extra/site-watcher/site-watcher.factor b/extra/site-watcher/site-watcher.factor
index 535c8cd6261e942548cd35f027b07ed5fc475114..dcae438679e80c4eacd9e2adbd7e17e0ab1a8899 100644 (file)
--- a/extra/site-watcher/site-watcher.factor
+++ b/extra/site-watcher/site-watcher.factor
@@ -10,7 +10,7 @@ SYMBOL: site-watcher-frequency
 5 minutes site-watcher-frequency set-global
  
 SYMBOL: running-site-watcher
-[ f running-site-watcher set-global ] "site-watcher" add-init-hook
+[ f running-site-watcher set-global ] "site-watcher" add-startup-hook
 
 <PRIVATE
 

diff --git a/extra/tetris/tetris.factor b/extra/tetris/tetris.factor
index dbdb666e4a39042aedff5c9276023441a3567b0a..66df0cdb2d7161f82549b5891ec92c045f60abef 100644 (file)
--- a/extra/tetris/tetris.factor
+++ b/extra/tetris/tetris.factor
@@ -13,8 +13,9 @@ M: tetris-gadget pref-dim* drop { 200 400 } ;
 
 : update-status ( gadget -- )
     dup tetris>> [
-        "Level: " % dup level>> #
-        " Score: " % score>> #
+        [ "Level: " % level>> # ]
+        [ " Score: " % score>> # ]
+        [ paused?>> [ " (Paused)" % ] when ] tri
     ] "" make swap show-status ;
 
 M: tetris-gadget draw-gadget* ( gadget -- )
@@ -25,17 +26,24 @@ M: tetris-gadget draw-gadget* ( gadget -- )
 : new-tetris ( gadget -- gadget )
     [ <new-tetris> ] change-tetris ;
 
+: unless-paused ( tetris quot -- )
+    over tetris>> paused?>> [
+        2drop
+    ] [
+        call
+    ] if ; inline
+
 tetris-gadget H{
     { T{ button-down f f 1 }     [ request-focus ] }
-    { T{ key-down f f "UP" }     [ tetris>> rotate-right ] }
-    { T{ key-down f f "d" }      [ tetris>> rotate-left ] }
-    { T{ key-down f f "f" }      [ tetris>> rotate-right ] }
-    { T{ key-down f f "e" }      [ tetris>> rotate-left ] } ! dvorak d
-    { T{ key-down f f "u" }      [ tetris>> rotate-right ] } ! dvorak f
-    { T{ key-down f f "LEFT" }   [ tetris>> move-left ] }
-    { T{ key-down f f "RIGHT" }  [ tetris>> move-right ] }
-    { T{ key-down f f "DOWN" }   [ tetris>> move-down ] }
-    { T{ key-down f f " " }      [ tetris>> move-drop ] }
+    { T{ key-down f f "UP" }     [ [ tetris>> rotate-right ] unless-paused ] }
+    { T{ key-down f f "d" }      [ [ tetris>> rotate-left ] unless-paused ] }
+    { T{ key-down f f "f" }      [ [ tetris>> rotate-right ] unless-paused ] }
+    { T{ key-down f f "e" }      [ [ tetris>> rotate-left ] unless-paused ] }
+    { T{ key-down f f "u" }      [ [ tetris>> rotate-right ] unless-paused ] }
+    { T{ key-down f f "LEFT" }   [ [ tetris>> move-left ] unless-paused ] }
+    { T{ key-down f f "RIGHT" }  [ [ tetris>> move-right ] unless-paused ] }
+    { T{ key-down f f "DOWN" }   [ [ tetris>> move-down ] unless-paused ] }
+    { T{ key-down f f " " }      [ [ tetris>> move-drop ] unless-paused ] }
     { T{ key-down f f "p" }      [ tetris>> toggle-pause ] }
     { T{ key-down f f "n" }      [ new-tetris drop ] }
 } set-gestures

diff --git a/vm/factor.cpp b/vm/factor.cpp
index 589d1898b15ab83e05b8b83aaf9fc4433bad3a8a..525b2fa43ed57d63da11314d726eb3f7c815928a 100755 (executable)
--- a/vm/factor.cpp
+++ b/vm/factor.cpp
@@ -171,6 +171,13 @@ void factor_vm::start_factor(vm_parameters *p)
        unnest_stacks();
 }
 
+void factor_vm::stop_factor()
+{
+       nest_stacks(NULL);
+       c_to_factor_toplevel(special_objects[OBJ_SHUTDOWN]);
+       unnest_stacks();
+}
+
 char *factor_vm::factor_eval_string(char *string)
 {
        char *(*callback)(char *) = (char *(*)(char *))alien_offset(special_objects[OBJ_EVAL_CALLBACK]);

diff --git a/vm/objects.hpp b/vm/objects.hpp
index 3eb2fdcce511a72e007ea8933b665aa68d4b7ddc..658f7eaa36630b5e184bc231b5d2113f0df88bb4 100644 (file)
--- a/vm/objects.hpp
+++ b/vm/objects.hpp
@@ -34,6 +34,7 @@ enum special_object {
 
        OBJ_BOOT            = 20, /* boot quotation */
        OBJ_GLOBAL,               /* global namespace */
+       OBJ_SHUTDOWN,
 
        /* Quotation compilation in quotations.c */
        JIT_PROLOG          = 23,

diff --git a/vm/vm.hpp b/vm/vm.hpp
index 0e4762d6c5cb8c4e593378b8319c6d654069a032..c1f7fdb1295ce8319fdbe877484ca83172fb2e87 100755 (executable)
--- a/vm/vm.hpp
+++ b/vm/vm.hpp
@@ -655,6 +655,7 @@ struct factor_vm
        void init_factor(vm_parameters *p);
        void pass_args_to_factor(int argc, vm_char **argv);
        void start_factor(vm_parameters *p);
+       void stop_factor();
        void start_embedded_factor(vm_parameters *p);
        void start_standalone_factor(int argc, vm_char **argv);
        char *factor_eval_string(char *string);