Last active
August 14, 2019 12:30
-
-
Save maximvl/dcb8c4e9ef5d4db91f7a6b52da9b9cee to your computer and use it in GitHub Desktop.
CL condition-restarts in Red
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Red [ | |
author: "Maxim Velesyuk" | |
description: "Common Lisp condition-restart system implementation for Red" | |
] | |
; utils | |
*word-counter*: 0 | |
gen-word: does [ | |
*word-counter*: *word-counter* + 1 | |
to-word append "G-" to-string *word-counter* | |
] | |
; register custom error type | |
system/catalog/errors: make system/catalog/errors [ | |
condition: object [ | |
code: 42 | |
type: "CL-style condition" | |
simple: ["simple" :arg1] | |
tag: ["tag" :arg1] | |
] | |
] | |
; stacks for handlers and restarts | |
*handler-stack*: copy [] | |
*restart-stack*: copy [] | |
; adds handler to handlers stack to be executed in case of error inside body | |
; removes handler afterwards | |
handler-bind: func [signal-type bind-callback body /local ret] [ | |
insert *handler-stack* reduce [signal-type :bind-callback] | |
error? ret: try [body] | |
take/part *handler-stack* 2 | |
ret | |
] | |
; runs code with custom callback provided | |
; this callback is called in case of error with error object as an argument | |
; result of this callback will be the result of whole call in case of error | |
handler-case: func [signal-type case-callback body | |
/local ret tag bind-callback] [ | |
tag: gen-word | |
bind-callback: func [e /local value] compose/deep [ | |
value: case-callback e | |
cause-error 'condition 'tag [(to-lit-word tag) value] | |
] | |
if error? ret: try [ handler-bind signal-type :bind-callback :body ] [ | |
if all [ ret/type = 'condition ret/id = 'tag ret/arg1 = tag ] [ | |
; return saved value | |
return ret/arg2 | |
] | |
] | |
ret | |
] | |
; lookups for closest matching handler in handlers stack | |
; runs this handler with custom error | |
; (handler may raise new error to change execution flow, e.g. `handler-case`) | |
; continues normal execution flow afterwords | |
fire-signal: func [signal-type data /local e handler] [ | |
e: make error! [type: 'condition id: 'simple arg1: signal-type arg2: data] | |
if handler: select *handler-stack* e/arg1 [ handler :e ] | |
] | |
; runs fire-signal handler | |
; if handler was found - it will raise another error and go through different execution path | |
; otherwise re-raise original error | |
fire-error: func [error] [ | |
fire-signal error | |
; error stops program if handler not found | |
; CL invokes debugger here | |
error | |
] | |
; same as handler-bind but for restart stack | |
; instead of error type uses arbitary `name` | |
restart-bind: func [name bind-callback body] [ | |
insert *restart-stack* reduce [name :bind-callback] | |
error? ret: try [body] | |
take/part *restart-stack* 2 | |
ret | |
] | |
; same as handler-aces but for restart stack | |
; same thing, accepts arbitary name | |
restart-case: func [name case-callback body] [ | |
tag: gen-word | |
bind-callback: func [e /local value] compose/deep [ | |
value: case-callback e | |
cause-error 'condition 'tag [(to-lit-word tag) value] | |
] | |
if error? ret: try [ restart-bind name :bind-callback :body] [ | |
if all [ ret/type = 'condition ret/id = 'tag ret/arg1 = tag ] [ | |
return ret/arg2 | |
] | |
] | |
ret | |
] | |
; similar to fire-signal, lookups for name instead and just returns it | |
find-restart: func [name /throw-not-found /local restart] [ | |
if restart: select *restart-stack* name [ return :restart ] | |
if throw-not-found [ throw 'restart-not-found ] | |
] | |
; finds and executes restart | |
invoke-restart: func [name param /local restart] [ | |
restart: find-restart/throw-not-found name | |
restart param | |
] | |
; runs body and actions afterwards regardless if body had an error or not | |
unwind-protect: func [body actions /local ret] [ | |
error? ret: try [body] | |
forall actions [ do actions/1 ] | |
ret | |
] | |
; how it works, examples | |
; simple signal with executing handler | |
; function fires signal if y is zero | |
; returns 0 regardless if signal was handled or not | |
div-signal: func [x y] [ | |
if zero? y [ | |
fire-signal 'zero x | |
return 0 | |
] | |
x / y | |
] | |
; handler-bind catches 'zero signal, runs simple handler and returns what `div-signal` returns | |
val: handler-bind 'zero does [ | |
print "i'm inside div-signal" | |
] has [res] [ | |
print "entering signal-func" | |
res: div-signal 5 0 | |
print ["returning" res "from body"] | |
res | |
] | |
print ["value:" val newline] | |
; handle error and return custom value from handler | |
; same, but fire error this time | |
; if handler is not found error is propagated to the top level | |
div-error: func [x y] [ | |
if zero? y [ | |
fire-error 'zero x | |
] | |
x / y | |
] | |
; handler-case catches 'zero error, and overrides original return value, stopping the error | |
val: handler-case 'zero func [e] [ | |
print ["i'm in div-error, found " e/type ", returning -1 instead"] | |
-1 | |
] has [res] [ | |
print "entering error-func" | |
res: div-error 5 0 | |
res | |
] | |
print ["value:" val newline] | |
; restart invocation example | |
; function by itself provides a way to solve the problem: | |
; restart `return-value` returns arbitary value on error | |
div-restart: func [x y /local callback] [ | |
callback: func [param] [ | |
print "entering restart return-value" | |
print ["returning" param "from restart"] | |
param | |
] | |
print "before restart-case" | |
restart-case "return-value" :callback does compose [div-error (x) (y)] | |
] | |
; we bind 'zero handler which decides to lookup for restart `return-value` | |
; and invoke that restart with value 42 | |
val: handler-bind 'zero func [e] [ | |
print "entering handler callback" | |
print "invoking restart return-value with param = 42" | |
invoke-restart "return-value" 42 | |
] has [res] [ | |
print "entering handler-bind with restart" | |
div-restart 5 0 | |
] | |
print ["value:" val newline] | |
; unwind-protect | |
; ensures that actions code runs in any case | |
val: handler-case 'zero func [e] [ | |
print ["i'm in div-error, found " e/type ", returning -5 instead"] | |
-5 | |
] has [res] [ | |
print "entering error-func under unwind-protect" | |
res: unwind-protect does [div-error 5 0] [ | |
[print "change 0 in div-error above, I'll be invoked anyway, usually to do the clean-up"] | |
] | |
res | |
] | |
print ["value:" val newline] | |
; >red restarts.red | |
; entering signal-func | |
; i'm inside div-signal | |
; returning 0 from body | |
; value: 0 | |
; entering error-func | |
; i'm in div-error, found condition , returning -1 instead | |
; value: -1 | |
; entering handler-bind with restart | |
; before restart-case | |
; entering handler callback | |
; invoking restart return-value with param = 42 | |
; entering restart return-value | |
; returning 42 from restart | |
; value: 42 | |
; entering error-func under unwind-protect | |
; i'm in div-error, found condition , returning -5 instead | |
; change 0 in div-error above, I'll be invoked anyway | |
; value: -5 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment