From 6e516789d5c8f9072347c846fd1e8ea8cbd75924 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 20 Feb 2010 13:41:33 +1300
Subject: [PATCH] continuations: add a throw-continue word for resumable
 errors, and change vocabs.metadata to throw a resumable error if the current
 platform is not supported

---
 basis/vocabs/metadata/metadata.factor        | 17 +++++++++++------
 core/compiler/units/units.factor             |  3 +--
 core/continuations/continuations-docs.factor | 12 ++++++++++--
 core/continuations/continuations.factor      |  3 +++
 4 files changed, 25 insertions(+), 10 deletions(-)

diff --git a/basis/vocabs/metadata/metadata.factor b/basis/vocabs/metadata/metadata.factor
index 10e4eac2a2..09ca012fcc 100644
--- a/basis/vocabs/metadata/metadata.factor
+++ b/basis/vocabs/metadata/metadata.factor
@@ -100,19 +100,24 @@ ERROR: bad-platform name ;
     [ [ name>> ] map ] dip
     dup vocab-platforms-path set-vocab-file-contents ;
 
-: supported-platform? ( vocab -- ? )
-    vocab-platforms [ t ] [ [ os swap class<= ] any? ] if-empty ;
+: supported-platform? ( platforms -- ? )
+    [ t ] [ [ os swap class<= ] any? ] if-empty ;
 
 : unportable? ( vocab -- ? )
     {
         [ vocab-tags "untested" swap member? ]
-        [ supported-platform? not ]
+        [ vocab-platforms supported-platform? not ]
     } 1|| ;
 
-ERROR: unsupported-platform vocab ;
+TUPLE: unsupported-platform vocab requires ;
+
+: unsupported-platform ( vocab requires -- )
+    \ unsupported-platform boa throw-continue ;
 
 M: unsupported-platform summary
     drop "Current operating system not supported by this vocabulary" ;
 
-[ dup supported-platform? [ drop ] [ vocab-name unsupported-platform ] if ]
-check-vocab-hook set-global
+[
+    dup vocab-platforms dup supported-platform?
+    [ 2drop ] [ [ vocab-name ] dip unsupported-platform ] if
+] check-vocab-hook set-global
diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor
index 9582ebadb6..b024ed2c65 100644
--- a/core/compiler/units/units.factor
+++ b/core/compiler/units/units.factor
@@ -12,8 +12,7 @@ SYMBOL: new-definitions
 TUPLE: redefine-error def ;
 
 : redefine-error ( definition -- )
-    \ redefine-error boa
-    { { "Continue" t } } throw-restarts drop ;
+    \ redefine-error boa throw-continue ;
 
 <PRIVATE
 
diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor
index 84da26a082..766a78c483 100644
--- a/core/continuations/continuations-docs.factor
+++ b/core/continuations/continuations-docs.factor
@@ -9,9 +9,13 @@ ARTICLE: "errors-restartable" "Restartable errors"
     throw-restarts
     rethrow-restarts
 }
+"A utility word using the above:"
+{ $subsections
+    throw-continue
+}
 "The list of restarts from the most recently-thrown error is stored in a global variable:"
 { $subsections restarts }
-"To invoke restarts, see " { $link "debugger" } "." ;
+"To invoke restarts, use " { $link "debugger" } "." ;
 
 ARTICLE: "errors-post-mortem" "Post-mortem error inspection"
 "The most recently thrown error, together with the continuation at that point, are stored in a pair of global variables:"
@@ -213,7 +217,11 @@ HELP: rethrow-restarts
 { $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } }
 { $description "Throws a restartable error using " { $link rethrow } ". Otherwise, this word is identical to " { $link throw-restarts } "." } ;
 
-{ throw rethrow throw-restarts rethrow-restarts } related-words
+{ throw rethrow throw-restarts rethrow-restarts throw-continue } related-words
+
+HELP: throw-continue
+{ $values { "error" object } }
+{ $description "Throws a resumable error. If the user elects to continue execution, this word returns normally." } ;
 
 HELP: compute-restarts
 { $values { "error" object } { "seq" "a sequence" } }
diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor
index d63acae883..332354e302 100644
--- a/core/continuations/continuations.factor
+++ b/core/continuations/continuations.factor
@@ -149,6 +149,9 @@ C: <condition> condition ( error restarts cc -- condition )
 : rethrow-restarts ( error restarts -- restart )
     [ <condition> rethrow ] callcc1 2nip ;
 
+: throw-continue ( error -- )
+    { { "Continue" t } } throw-restarts drop ;
+
 TUPLE: restart name obj continuation ;
 
 C: <restart> restart