diff options
| -rw-r--r-- | src/lem_interp/interp_inter_imp.lem | 27 |
1 files changed, 18 insertions, 9 deletions
diff --git a/src/lem_interp/interp_inter_imp.lem b/src/lem_interp/interp_inter_imp.lem index 0f7d71c7..714f4c4c 100644 --- a/src/lem_interp/interp_inter_imp.lem +++ b/src/lem_interp/interp_inter_imp.lem @@ -241,22 +241,31 @@ let initial_instruction_state top_level main args = Interp.Thunk_frame (E_aux (E_app (Id_aux (Id main) Interp_ast.Unknown) e_args) (Interp_ast.Unknown, Nothing)) top_level Interp.eenv (Interp.emem "istate top level") Interp.Top +type interp_value_helper_mode = Ivh_decode | Ivh_unsupported | Ivh_illegal -let rec interp_to_value_helper arg err_str instr direction thunk = +let rec interp_to_value_helper arg ivh_mode err_str instr direction thunk = match thunk() with - | (Interp.Value value,_,_) -> (Just value,Nothing) - | (Interp.Error l msg,_,_) -> (Nothing, Just (Internal_error msg)) + | (Interp.Value value,_,_) -> + (match value with + | Interp.V_ctor (Id_aux (Id "Some") _) _ _ vinstr -> (Just vinstr,Nothing) + | Interp.V_ctor (Id_aux (Id "None") _) _ _ _ -> + match ivh_mode with + | Ivh_decode -> (Nothing, Just (Not_an_instruction_error arg)) + | Ivh_illegal -> (Nothing, Just (Not_an_instruction_error arg)) + | Ivh_unsupported -> (Nothing, Just (Unsupported_instruction_error instr)) + end end) + | (Interp.Error l msg,_,_) -> (Nothing, Just (Internal_error msg)) | (Interp.Action (Interp.Call_extern i value) stack,_,_) -> match List.lookup i (Interp_lib.library_functions direction) with | Nothing -> (Nothing, Just (Internal_error ("External function not available " ^ i))) | Just f -> - interp_to_value_helper arg err_str instr direction + interp_to_value_helper arg ivh_mode err_str instr direction (fun _ -> Interp.resume (make_interp_mode true false) stack (Just (f value))) end | (Interp.Action (Interp.Exit ((E_aux e _) as exp)) stack,_,_) -> match e with - | E_id (Id_aux (Id "unsupported_instruction") _) -> (Nothing,Just (Unsupported_instruction_error instr)) - | E_id (Id_aux (Id "no_matching_pattern") _) -> (Nothing,Just (Not_an_instruction_error arg)) + (*| E_id (Id_aux (Id "unsupported_instruction") _) -> (Nothing,Just (Unsupported_instruction_error instr)) + | E_id (Id_aux (Id "no_matching_pattern") _) -> (Nothing,Just (Not_an_instruction_error arg))*) | E_lit (L_aux (L_string str) _) -> (Nothing, Just (Internal_error ("Exit called with message: " ^ str))) | E_id (Id_aux (Id i) _) -> (match (Interp.resume (make_interp_mode true false) (Interp.set_in_context stack exp) Nothing) with @@ -322,7 +331,7 @@ let decode_to_istate top_level value = let val_str = Interp.string_of_value intern_val in let (arg,_) = Interp.to_exp mode Interp.eenv intern_val in let internal_direction = if direction = D_increasing then Interp.IInc else Interp.IDec in - let (instr_decoded,error) = interp_to_value_helper value val_str ("",[],[]) internal_direction + let (instr_decoded,error) = interp_to_value_helper value Ivh_decode val_str ("",[],[]) internal_direction (fun _ -> Interp.resume mode (Interp.Thunk_frame @@ -331,7 +340,7 @@ let decode_to_istate top_level value = match (instr_decoded,error) with | (Just instr, _) -> let instr_external = match instr with - | Interp.V_ctor (Id_aux (Id i) _) _ _ parm -> + | Interp.V_ctor (Id_aux (Id "Some") _) _ _ (Interp.V_ctor (Id_aux (Id i) _) _ _ parm) -> match (find_instruction i instructions) with | Just(Instruction_extractor.Instr_form name parms effects) -> match (parm,parms) with @@ -346,7 +355,7 @@ let decode_to_istate top_level value = (p_name,t,(extern_ifield_value name p_name value t))) vals parms), effects) end end end in let (arg,_) = Interp.to_exp mode Interp.eenv instr in - let (instr_decoded,error) = interp_to_value_helper value val_str instr_external internal_direction + let (instr_decoded,error) = interp_to_value_helper value Ivh_unsupported val_str instr_external internal_direction (fun _ -> Interp.resume mode (Interp.Thunk_frame |