diff options
| author | Alasdair Armstrong | 2019-02-04 16:43:32 +0000 |
|---|---|---|
| committer | Alasdair Armstrong | 2019-02-04 16:43:32 +0000 |
| commit | 4910e06ae9cf8f479c76fea39b4334407942da4e (patch) | |
| tree | 6d39cecf2352b9584b48e61df24556b419df055e /src/interpreter.ml | |
| parent | ebfed17b57993f034d1a334014a8b9c9a542c0d5 (diff) | |
Fix behavior for fallthrough cases in catch blocks
Make all backends behave the same when a catch block does not catch a
specific exception.
Diffstat (limited to 'src/interpreter.ml')
| -rw-r--r-- | src/interpreter.ml | 11 |
1 files changed, 10 insertions, 1 deletions
diff --git a/src/interpreter.ml b/src/interpreter.ml index 40ee251d..1e1bb816 100644 --- a/src/interpreter.ml +++ b/src/interpreter.ml @@ -110,6 +110,15 @@ let value_of_exp = function | (E_aux (E_internal_value v, _)) -> v | _ -> failwith "value_of_exp coerction failed" +let fallthrough = + let open Type_check in + try + let env = initial_env |> Env.add_scattered_variant (mk_id "exception") (mk_typquant []) in + check_case env exc_typ (mk_pexp (Pat_exp (mk_pat (P_id (mk_id "exn")), mk_exp (E_throw (mk_exp (E_id (mk_id "exn"))))))) unit_typ + with + | Type_error (_, l, err) -> + Reporting.unreachable l __POS__ (Type_error.string_of_type_error err); + (**************************************************************************) (* 1. Interpreter Monad *) (**************************************************************************) @@ -491,7 +500,7 @@ let rec step (E_aux (e_aux, annot) as orig_exp) = begin catch (step exp) >>= fun exp' -> match exp' with - | Left exn -> wrap (E_case (exp_of_value exn, pexps)) + | Left exn -> wrap (E_case (exp_of_value exn, pexps @ [fallthrough])) | Right exp' -> wrap (E_try (exp', pexps)) end |