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
parent
1915b7e955
commit
6e516789d5
|
@ -100,19 +100,24 @@ ERROR: bad-platform name ;
|
||||||
[ [ name>> ] map ] dip
|
[ [ name>> ] map ] dip
|
||||||
dup vocab-platforms-path set-vocab-file-contents ;
|
dup vocab-platforms-path set-vocab-file-contents ;
|
||||||
|
|
||||||
: supported-platform? ( vocab -- ? )
|
: supported-platform? ( platforms -- ? )
|
||||||
vocab-platforms [ t ] [ [ os swap class<= ] any? ] if-empty ;
|
[ t ] [ [ os swap class<= ] any? ] if-empty ;
|
||||||
|
|
||||||
: unportable? ( vocab -- ? )
|
: unportable? ( vocab -- ? )
|
||||||
{
|
{
|
||||||
[ vocab-tags "untested" swap member? ]
|
[ vocab-tags "untested" swap member? ]
|
||||||
[ supported-platform? not ]
|
[ vocab-platforms supported-platform? not ]
|
||||||
} 1|| ;
|
} 1|| ;
|
||||||
|
|
||||||
ERROR: unsupported-platform vocab ;
|
TUPLE: unsupported-platform vocab requires ;
|
||||||
|
|
||||||
|
: unsupported-platform ( vocab requires -- )
|
||||||
|
\ unsupported-platform boa throw-continue ;
|
||||||
|
|
||||||
M: unsupported-platform summary
|
M: unsupported-platform summary
|
||||||
drop "Current operating system not supported by this vocabulary" ;
|
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
|
||||||
|
|
|
@ -12,8 +12,7 @@ SYMBOL: new-definitions
|
||||||
TUPLE: redefine-error def ;
|
TUPLE: redefine-error def ;
|
||||||
|
|
||||||
: redefine-error ( definition -- )
|
: redefine-error ( definition -- )
|
||||||
\ redefine-error boa
|
\ redefine-error boa throw-continue ;
|
||||||
{ { "Continue" t } } throw-restarts drop ;
|
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
|
|
|
@ -9,9 +9,13 @@ ARTICLE: "errors-restartable" "Restartable errors"
|
||||||
throw-restarts
|
throw-restarts
|
||||||
rethrow-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:"
|
"The list of restarts from the most recently-thrown error is stored in a global variable:"
|
||||||
{ $subsections restarts }
|
{ $subsections restarts }
|
||||||
"To invoke restarts, see " { $link "debugger" } "." ;
|
"To invoke restarts, use " { $link "debugger" } "." ;
|
||||||
|
|
||||||
ARTICLE: "errors-post-mortem" "Post-mortem error inspection"
|
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:"
|
"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 } }
|
{ $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 } "." } ;
|
{ $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
|
HELP: compute-restarts
|
||||||
{ $values { "error" object } { "seq" "a sequence" } }
|
{ $values { "error" object } { "seq" "a sequence" } }
|
||||||
|
|
|
@ -149,6 +149,9 @@ C: <condition> condition ( error restarts cc -- condition )
|
||||||
: rethrow-restarts ( error restarts -- restart )
|
: rethrow-restarts ( error restarts -- restart )
|
||||||
[ <condition> rethrow ] callcc1 2nip ;
|
[ <condition> rethrow ] callcc1 2nip ;
|
||||||
|
|
||||||
|
: throw-continue ( error -- )
|
||||||
|
{ { "Continue" t } } throw-restarts drop ;
|
||||||
|
|
||||||
TUPLE: restart name obj continuation ;
|
TUPLE: restart name obj continuation ;
|
||||||
|
|
||||||
C: <restart> restart
|
C: <restart> restart
|
||||||
|
|
Loading…
Reference in New Issue