diff --git a/.depend b/.depend
index 4513260..c31b033 100644
--- a/.depend
+++ b/.depend
@@ -186,6 +186,42 @@ typing/datarepr.cmx : typing/types.cmx typing/path.cmx parsing/location.cmx \
     typing/ident.cmx typing/btype.cmx parsing/asttypes.cmi \
     typing/datarepr.cmi
 typing/datarepr.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi
+typing/debug_core.cmo : typing/typedtree.cmi parsing/pprintast.cmi \
+    parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
+    parsing/asttypes.cmi typing/debug_core.cmi
+typing/debug_core.cmx : typing/typedtree.cmx parsing/pprintast.cmx \
+    parsing/parsetree.cmi parsing/longident.cmx parsing/location.cmx \
+    parsing/asttypes.cmi typing/debug_core.cmi
+typing/debug_core.cmi : typing/typedtree.cmi parsing/parsetree.cmi \
+    parsing/asttypes.cmi
+typing/debug_main.cmo : utils/warnings.cmi typing/typetexp.cmi \
+    typing/types.cmi typing/typemod.cmi typing/typedtree.cmi \
+    typing/typedecl.cmi typing/typecore.cmi parsing/syntaxerr.cmi \
+    typing/printtyp.cmi parsing/pprintast.cmi typing/path.cmi \
+    parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
+    typing/env.cmi typing/debug_slice.cmi typing/debug_message.cmo \
+    typing/debug_core.cmi typing/ctype.cmi typing/btype.cmi \
+    parsing/asttypes.cmi parsing/ast_helper.cmi typing/debug_main.cmi
+typing/debug_main.cmx : utils/warnings.cmx typing/typetexp.cmx \
+    typing/types.cmx typing/typemod.cmx typing/typedtree.cmx \
+    typing/typedecl.cmx typing/typecore.cmx parsing/syntaxerr.cmx \
+    typing/printtyp.cmx parsing/pprintast.cmx typing/path.cmx \
+    parsing/parsetree.cmi parsing/longident.cmx parsing/location.cmx \
+    typing/env.cmx typing/debug_slice.cmx typing/debug_message.cmx \
+    typing/debug_core.cmx typing/ctype.cmx typing/btype.cmx \
+    parsing/asttypes.cmi parsing/ast_helper.cmx typing/debug_main.cmi
+typing/debug_main.cmi : parsing/parsetree.cmi typing/env.cmi
+typing/debug_message.cmo : typing/types.cmi parsing/syntaxerr.cmi \
+    typing/printtyp.cmi parsing/pprintast.cmi typing/path.cmi \
+    parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
+    typing/ident.cmi typing/debug_core.cmi
+typing/debug_message.cmx : typing/types.cmx parsing/syntaxerr.cmx \
+    typing/printtyp.cmx parsing/pprintast.cmx typing/path.cmx \
+    parsing/parsetree.cmi parsing/longident.cmx parsing/location.cmx \
+    typing/ident.cmx typing/debug_core.cmx
+typing/debug_slice.cmo : typing/debug_slice.cmi
+typing/debug_slice.cmx : typing/debug_slice.cmi
+typing/debug_slice.cmi : parsing/parsetree.cmi typing/env.cmi
 typing/env.cmo : utils/warnings.cmi typing/types.cmi utils/tbl.cmi \
     typing/subst.cmi typing/predef.cmi typing/path.cmi utils/misc.cmi \
     parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
@@ -1960,8 +1996,9 @@ driver/compile.cmo : utils/warnings.cmi typing/typemod.cmi \
     bytecomp/printinstr.cmi parsing/printast.cmi parsing/pprintast.cmi \
     driver/pparse.cmi utils/misc.cmi bytecomp/lambda.cmi \
     typing/includemod.cmi typing/env.cmi bytecomp/emitcode.cmi \
-    driver/compmisc.cmi driver/compenv.cmi utils/clflags.cmi \
-    bytecomp/bytegen.cmi parsing/builtin_attributes.cmi driver/compile.cmi
+    typing/debug_main.cmi driver/compmisc.cmi driver/compenv.cmi \
+    utils/clflags.cmi bytecomp/bytegen.cmi parsing/builtin_attributes.cmi \
+    driver/compile.cmi
 driver/compile.cmx : utils/warnings.cmx typing/typemod.cmx \
     typing/typedtree.cmx typing/typecore.cmx bytecomp/translmod.cmx \
     utils/timings.cmx typing/stypes.cmx bytecomp/simplif.cmx \
@@ -1969,8 +2006,9 @@ driver/compile.cmx : utils/warnings.cmx typing/typemod.cmx \
     bytecomp/printinstr.cmx parsing/printast.cmx parsing/pprintast.cmx \
     driver/pparse.cmx utils/misc.cmx bytecomp/lambda.cmx \
     typing/includemod.cmx typing/env.cmx bytecomp/emitcode.cmx \
-    driver/compmisc.cmx driver/compenv.cmx utils/clflags.cmx \
-    bytecomp/bytegen.cmx parsing/builtin_attributes.cmx driver/compile.cmi
+    typing/debug_main.cmx driver/compmisc.cmx driver/compenv.cmx \
+    utils/clflags.cmx bytecomp/bytegen.cmx parsing/builtin_attributes.cmx \
+    driver/compile.cmi
 driver/compile.cmi :
 driver/compmisc.cmo : typing/typemod.cmi utils/misc.cmi \
     parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
@@ -2155,10 +2193,11 @@ toplevel/toploop.cmo : utils/warnings.cmi typing/typetexp.cmi \
     typing/oprint.cmi utils/misc.cmi bytecomp/meta.cmi parsing/longident.cmi \
     parsing/location.cmi parsing/lexer.cmi typing/includemod.cmi \
     typing/ident.cmi toplevel/genprintval.cmi typing/env.cmi \
-    bytecomp/emitcode.cmi bytecomp/dll.cmi utils/consistbl.cmi \
-    utils/config.cmi driver/compmisc.cmi driver/compenv.cmi utils/clflags.cmi \
-    bytecomp/bytegen.cmi typing/btype.cmi parsing/asttypes.cmi \
-    parsing/ast_helper.cmi toplevel/toploop.cmi
+    bytecomp/emitcode.cmi bytecomp/dll.cmi typing/debug_main.cmi \
+    utils/consistbl.cmi utils/config.cmi driver/compmisc.cmi \
+    driver/compenv.cmi utils/clflags.cmi bytecomp/bytegen.cmi \
+    typing/btype.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \
+    toplevel/toploop.cmi
 toplevel/toploop.cmx : utils/warnings.cmx typing/typetexp.cmx \
     typing/types.cmx typing/typemod.cmx typing/typedtree.cmx \
     typing/typecore.cmx bytecomp/translmod.cmx bytecomp/symtable.cmx \
@@ -2169,10 +2208,11 @@ toplevel/toploop.cmx : utils/warnings.cmx typing/typetexp.cmx \
     typing/oprint.cmx utils/misc.cmx bytecomp/meta.cmx parsing/longident.cmx \
     parsing/location.cmx parsing/lexer.cmx typing/includemod.cmx \
     typing/ident.cmx toplevel/genprintval.cmx typing/env.cmx \
-    bytecomp/emitcode.cmx bytecomp/dll.cmx utils/consistbl.cmx \
-    utils/config.cmx driver/compmisc.cmx driver/compenv.cmx utils/clflags.cmx \
-    bytecomp/bytegen.cmx typing/btype.cmx parsing/asttypes.cmi \
-    parsing/ast_helper.cmx toplevel/toploop.cmi
+    bytecomp/emitcode.cmx bytecomp/dll.cmx typing/debug_main.cmx \
+    utils/consistbl.cmx utils/config.cmx driver/compmisc.cmx \
+    driver/compenv.cmx utils/clflags.cmx bytecomp/bytegen.cmx \
+    typing/btype.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \
+    toplevel/toploop.cmi
 toplevel/toploop.cmi : utils/warnings.cmi typing/types.cmi typing/path.cmi \
     parsing/parsetree.cmi typing/outcometree.cmi parsing/longident.cmi \
     parsing/location.cmi typing/env.cmi
diff --git a/.gitignore b/.gitignore
index 332ecb8..2a1172a 100644
--- a/.gitignore
+++ b/.gitignore
@@ -27,8 +27,6 @@
 *.annot
 *.exe
 *.exe.manifest
-.depend
-.depend.nt
 .DS_Store
 *.out
 *.out.dSYM
@@ -171,7 +169,6 @@
 /ocamldoc/test
 
 /otherlibs/dynlink/extract_crc
-/otherlibs/systhreads/thread.ml
 /otherlibs/threads/marshal.mli
 /otherlibs/threads/pervasives.mli
 /otherlibs/threads/unix.mli
diff --git a/Makefile.shared b/Makefile.shared
index 5ffccb4..3651295 100644
--- a/Makefile.shared
+++ b/Makefile.shared
@@ -71,7 +71,8 @@ TYPING=typing/ident.cmo typing/path.cmo \
   typing/includemod.cmo typing/typetexp.cmo typing/parmatch.cmo \
   typing/stypes.cmo typing/typedecl.cmo typing/typecore.cmo \
   typing/typeclass.cmo \
-  typing/typemod.cmo
+  typing/typemod.cmo typing/debug_core.cmo typing/debug_message.cmo \
+  typing/debug_slice.cmo typing/debug_main.cmo
 
 COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \
   bytecomp/typeopt.cmo bytecomp/switch.cmo bytecomp/matching.cmo \
diff --git a/driver/compile.ml b/driver/compile.ml
index 0d7325d..ebe3035 100644
--- a/driver/compile.ml
+++ b/driver/compile.ml
@@ -54,6 +54,11 @@ let interface ppf sourcefile outputprefix =
       initial_env sg ;
   end
 
+(* for type debugger *)
+
+(* input structure to be compiled *)
+let structure = ref []
+
 (* Compile a .ml file *)
 
 let print_if ppf flag printer arg =
@@ -69,7 +74,9 @@ let implementation ppf sourcefile outputprefix =
   let env = Compmisc.initial_env() in
   try
     let (typedtree, coercion) =
-      Pparse.parse_implementation ~tool_name ppf sourcefile
+      let str = Pparse.parse_implementation ~tool_name ppf sourcefile in
+      structure := str;
+      str (* Pparse.parse_implementation ~tool_name ppf sourcefile *)
       ++ print_if ppf Clflags.dump_parsetree Printast.implementation
       ++ print_if ppf Clflags.dump_source Pprintast.structure
       ++ Timings.(time (Typing sourcefile))
@@ -110,4 +117,10 @@ let implementation ppf sourcefile outputprefix =
     end
   with x ->
     Stypes.dump (Some (outputprefix ^ ".annot"));
-    raise x
+    if Debug_main.handle_simple_errors ppf x !structure Compmisc.initial_env
+    then exit 2
+    else begin (* launch type debugger *)
+      Debug_main.launch (Debug_core.hole_str :: !structure) Compmisc.initial_env;
+      exit 2
+      (* raise x *)
+    end
diff --git a/parsing/ast_iterator.ml b/parsing/ast_iterator.ml
index 8518438..7242c18 100755
--- a/parsing/ast_iterator.ml
+++ b/parsing/ast_iterator.ml
@@ -593,5 +593,6 @@ let default_iterator =
          | PSig x -> this.signature this x
          | PTyp x -> this.typ this x
          | PPat (x, g) -> this.pat this x; iter_opt (this.expr this) g
+         | _ -> assert false
       );
   }
diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml
index ec409be..22ef8ee 100644
--- a/parsing/ast_mapper.ml
+++ b/parsing/ast_mapper.ml
@@ -629,6 +629,7 @@ let default_mapper =
          | PSig x -> PSig (this.signature this x)
          | PTyp x -> PTyp (this.typ this x)
          | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g)
+         | Size x -> Size x (* 深さを持つ *)
       );
   }
 
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 1b642b2..52584fd 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -23,6 +23,19 @@ open Parsetree
 open Ast_helper
 open Docstrings
 
+let language_level = Syntaxerr.language_level
+(*
+let language_level = try
+  let lang = Sys.getenv "OCAML_LANGUAGE_LEVEL" in
+  match lang with
+    "1" -> 1
+  | "2" -> 2
+  | "3" -> 3
+  | "4" -> 4
+  | _ -> 4
+  with Not_found -> 4
+*)
+
 let mktyp d = Typ.mk ~loc:(symbol_rloc()) d
 let mkpat d = Pat.mk ~loc:(symbol_rloc()) d
 let mkexp d = Exp.mk ~loc:(symbol_rloc()) d
@@ -459,6 +472,13 @@ let package_type_of_module_type pmty =
       err pmty.pmty_loc
         "only module type identifier and 'with type' constraints are supported"
 
+let expert_exp str =
+  raise (Syntaxerr.Error (Syntaxerr.Expert_exp
+          (str, language_level, symbol_rloc ())))
+
+let infixop0 str loc =
+  raise (Syntaxerr.Error (Syntaxerr.InfixOP0
+          (str, language_level, loc)))
 
 %}
 
@@ -1305,10 +1325,16 @@ and_class_type_declaration:
 
 seq_expr:
   | expr        %prec below_SEMI  { $1 }
-  | expr SEMI                     { reloc_exp $1 }
-  | expr SEMI seq_expr            { mkexp(Pexp_sequence($1, $3)) }
+  | expr SEMI                     { if language_level < 3
+                                    then expert_exp "sequence"
+                                    else reloc_exp $1 }
+  | expr SEMI seq_expr            { if language_level < 3
+                                    then expert_exp "sequence"
+                                    else mkexp(Pexp_sequence($1, $3)) }
   | expr SEMI PERCENT attr_id seq_expr
-      { let seq = mkexp(Pexp_sequence ($1, $5)) in
+      { if language_level < 3
+        then expert_exp "sequence" else
+        let seq = mkexp(Pexp_sequence ($1, $5)) in
         let payload = PStr [mkstrexp seq []] in
         mkexp (Pexp_extension ($4, payload)) }
 ;
@@ -1388,18 +1414,30 @@ expr:
   | IF ext_attributes seq_expr THEN expr ELSE expr
       { mkexp_attrs(Pexp_ifthenelse($3, $5, Some $7)) $2 }
   | IF ext_attributes seq_expr THEN expr
-      { mkexp_attrs (Pexp_ifthenelse($3, $5, None)) $2 }
+      { if language_level < 3
+        then expert_exp "if"
+        else mkexp_attrs (Pexp_ifthenelse($3, $5, None)) $2 }
   | WHILE ext_attributes seq_expr DO seq_expr DONE
-      { mkexp_attrs (Pexp_while($3, $5)) $2 }
+      { if language_level < 4
+        then expert_exp "while"
+        else mkexp_attrs (Pexp_while($3, $5)) $2 }
   | FOR ext_attributes pattern EQUAL seq_expr direction_flag seq_expr DO
     seq_expr DONE
-      { mkexp_attrs(Pexp_for($3, $5, $7, $6, $9)) $2 }
+      { if language_level < 4
+        then expert_exp "for"
+        else mkexp_attrs(Pexp_for($3, $5, $7, $6, $9)) $2 }
   | expr COLONCOLON expr
       { mkexp_cons (rhs_loc 2) (ghexp(Pexp_tuple[$1;$3])) (symbol_rloc()) }
   | LPAREN COLONCOLON RPAREN LPAREN expr COMMA expr RPAREN
       { mkexp_cons (rhs_loc 2) (ghexp(Pexp_tuple[$5;$7])) (symbol_rloc()) }
   | expr INFIXOP0 expr
-      { mkinfix $1 $2 $3 }
+      { if language_level < 4
+        then begin match $2 with
+               "==" -> infixop0 "=" (rhs_loc 2)
+             | "!=" -> infixop0 "<>" (rhs_loc 2)
+             | _ -> mkinfix $1 $2 $3
+             end
+        else mkinfix $1 $2 $3 }
   | expr INFIXOP1 expr
       { mkinfix $1 $2 $3 }
   | expr INFIXOP2 expr
@@ -1437,7 +1475,9 @@ expr:
   | expr AMPERAMPER expr
       { mkinfix $1 "&&" $3 }
   | expr COLONEQUAL expr
-      { mkinfix $1 ":=" $3 }
+      { if language_level < 3
+        then expert_exp "assign"
+        else mkinfix $1 ":=" $3 }
   | subtractive expr %prec prec_unary_minus
       { mkuminus $1 $2 }
   | additive expr %prec prec_unary_plus
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index d61b339..216e2b8 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -61,6 +61,7 @@ and payload =
   | PSig of signature (* : SIG *)
   | PTyp of core_type  (* : T *)
   | PPat of pattern * expression option  (* ? P  or  ? P when E *)
+  | Size of int
 
 (** {2 Core language} *)
 
diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml
index f9e5152..3f77e6e 100644
--- a/parsing/pprintast.ml
+++ b/parsing/pprintast.ml
@@ -1063,6 +1063,7 @@ and payload ctxt f = function
   | PPat (x, Some e) ->
       pp f "?"; pattern ctxt f x;
       pp f " when "; expression ctxt f e
+  | Size x -> print_int x
 
 (* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *)
 and binding ctxt f {pvb_pat=p; pvb_expr=x; _} =
diff --git a/parsing/printast.ml b/parsing/printast.ml
index 673defb..de2a543 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -419,7 +419,7 @@ and payload i ppf = function
     pattern i ppf x;
     line i ppf "<when>\n";
     expression (i + 1) ppf g
-
+  | Size x -> print_int x
 
 and type_kind i ppf x =
   match x with
diff --git a/parsing/syntaxerr.ml b/parsing/syntaxerr.ml
index 0bb55ab..bfdc306 100644
--- a/parsing/syntaxerr.ml
+++ b/parsing/syntaxerr.ml
@@ -13,6 +13,31 @@
 (*                                                                        *)
 (**************************************************************************)
 
+(* language levels *)
+
+type language_t = English | Japanese
+
+let language = try
+  let lang = Sys.getenv "LANG" in
+  if String.sub lang 0 (min 5 (String.length lang)) = "ja_JP"
+  then Japanese
+  else English
+with Not_found -> English
+
+let language_level = try
+  let lang = Sys.getenv "OCAML_LANGUAGE_LEVEL" in
+  match lang with
+    "1" -> 1
+  | "2" -> 2
+  | "3" -> 3
+  | "4" -> 4
+  | _ -> 4
+  with Not_found -> 4
+
+let errorf ?(loc = Location.none) en ja = match language with
+    English -> Location.errorf ~loc en
+  | Japanese -> Location.errorf ~loc ja
+
 (* Auxiliary type for reporting syntax errors *)
 
 type error =
@@ -21,6 +46,8 @@ type error =
   | Not_expecting of Location.t * string
   | Applicative_path of Location.t
   | Variable_in_scope of Location.t * string
+  | Expert_exp of string * int * Location.t
+  | InfixOP0 of string * int * Location.t
   | Other of Location.t
   | Ill_formed_ast of Location.t * string
   | Invalid_package_type of Location.t * string
@@ -54,6 +81,41 @@ let prepare_error = function
         "In this scoped type, variable '%s \
          is reserved for the local type %s."
          var var
+  (* language levels *)
+  | Expert_exp (str, level, loc) ->
+      begin match str with
+        "if" ->
+          errorf ~loc
+            "L%dError1: did you forget the else part?"
+            "L%dError1: else 部分を忘れていませんか？"
+            level
+      | "for" ->
+          errorf ~loc
+            "L%dError2: for not allowed at this language level"
+            "L%dError2: この言語レベルでは for 文を使うことはできません"
+            level
+      | "while" ->
+          errorf ~loc
+            "L%dError3: while not allowed at this language level"
+            "L%dError3: この言語レベルでは while 文を使うことはできません"
+            level
+      | "sequence" ->
+          errorf ~loc
+            "L%dError4: sequential execution not allowed at this language level"
+            "L%dError4: この言語レベルでは逐次実行文を使うことはできません"
+            level
+      | "assign" ->
+          errorf ~loc
+            "L%dError5: assignments not allowed at this language level"
+            "L%dError5: この言語レベルでは代入文を使うことはできません"
+            level
+      | _ -> Location.error ~loc ("Unsupported Expert_exp error: " ^ str)
+      end
+  | InfixOP0 (str, level, loc) ->
+      errorf ~loc
+        "L%dError6: use %s."
+        "L%dError6: %s を使いましょう"
+        level str
   | Other loc ->
       Location.errorf ~loc "Syntax error"
   | Ill_formed_ast (loc, s) ->
@@ -76,6 +138,8 @@ let location_of_error = function
   | Unclosed(l,_,_,_)
   | Applicative_path l
   | Variable_in_scope(l,_)
+  | Expert_exp (_, _, l)
+  | InfixOP0 (_, _, l)
   | Other l
   | Not_expecting (l, _)
   | Ill_formed_ast (l, _)
diff --git a/parsing/syntaxerr.mli b/parsing/syntaxerr.mli
index 319eb57..996dcfb 100644
--- a/parsing/syntaxerr.mli
+++ b/parsing/syntaxerr.mli
@@ -13,6 +13,12 @@
 (*                                                                        *)
 (**************************************************************************)
 
+(* language levels *)
+
+type language_t = English | Japanese
+val language : language_t
+val language_level : int
+
 (** Auxiliary type for reporting syntax errors *)
 
 open Format
@@ -23,6 +29,8 @@ type error =
   | Not_expecting of Location.t * string
   | Applicative_path of Location.t
   | Variable_in_scope of Location.t * string
+  | Expert_exp of string * int * Location.t
+  | InfixOP0 of string * int * Location.t
   | Other of Location.t
   | Ill_formed_ast of Location.t * string
   | Invalid_package_type of Location.t * string
diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml
index e832fde..4a141b7 100644
--- a/toplevel/toploop.ml
+++ b/toplevel/toploop.ml
@@ -241,6 +241,26 @@ let add_directive name dir_fun dir_info =
   Hashtbl.add directive_table name dir_fun;
   Hashtbl.add directive_info_table name dir_info
 
+(* for type debugger *)
+
+(* structures input so far in the reverse order *)
+let rev_structures = ref []
+
+(* the last input phrase *)
+let last_phrase = ref (Ptop_def [])
+
+let structure_of_phrase phr = match phr with
+    Ptop_dir (str, _) -> (print_string str; assert false)
+  | Ptop_def (str) -> str
+
+let rec rev_flatten structures acc = match structures with
+    [] -> acc
+  | structure :: rest -> rev_flatten rest (structure @ acc)
+
+(* cons_structure : structure -> structure list -> structure *)
+let cons_structure structure rev_structures =
+  rev_flatten (structure :: rev_structures) []
+
 (* Execute a toplevel phrase *)
 
 let execute_phrase print_outcome ppf phr =
@@ -291,6 +311,7 @@ let execute_phrase print_outcome ppf phr =
               Ophr_exception (exn, outv)
         in
         !print_out_phrase ppf out_phr;
+        rev_structures := sstr :: !rev_structures;
         if Printexc.backtrace_status ()
         then begin
           match !backtrace with
@@ -350,7 +371,15 @@ let execute_phrase print_outcome ppf phr =
   try execute_phrase print_outcome ppf phr
   with exn ->
     Warnings.reset_fatal ();
-    raise exn
+    let last_str = structure_of_phrase !last_phrase in
+    let structure = cons_structure last_str !rev_structures in
+    if Debug_main.handle_simple_errors ppf exn structure Compmisc.initial_env
+    then false
+    else begin (* launch type debugger *)
+      Debug_main.launch (Debug_core.hole_str :: structure) Compmisc.initial_env;
+      false
+    end
+    (* raise exn *)
 
 (* Read and execute commands from a file, or from stdin if [name] is "". *)
 
@@ -395,6 +424,7 @@ let use_file ppf wrap_mod name =
           List.iter
             (fun ph ->
               let ph = preprocess_phrase ppf ph in
+              last_phrase := ph;
               if not (execute_phrase !use_print_results ppf ph) then raise Exit)
             (if wrap_mod then
                parse_mod_use_file name lb
@@ -534,6 +564,7 @@ let loop ppf =
       first_line := true;
       let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in
       let phr = preprocess_phrase ppf phr  in
+      last_phrase := phr;
       Env.reset_cache_toplevel ();
       ignore(execute_phrase true ppf phr)
     with
diff --git a/typing/debug_core.ml b/typing/debug_core.ml
new file mode 100755
index 0000000..9daa2a9
--- /dev/null
+++ b/typing/debug_core.ml
@@ -0,0 +1,1060 @@
+open Asttypes
+open Ast_helper
+
+open Types
+open Typedtree
+
+open Parsetree
+
+(* ppf *)
+let ppf = Format.std_formatter
+
+(* コンテキストの定義 *)
+type expr_context =
+  Empty
+| Lambda of pattern * expr_context
+| Let of rec_flag * value_binding list * expr_context
+type 'a context_t =
+  ('a * expr_context) * Env.t * (structure_item * Env.t) list
+
+(* ---------------------------------------------------------- *)
+
+(* map 関数の集合 *)
+module Map = struct
+
+  type 'a map2 = (pattern -> expression -> expression)
+                 -> (pattern -> expression -> pattern)
+                 -> 'a -> 'a
+  type 'a map1 = (expression -> expression) -> (pattern -> pattern)
+                 -> 'a -> 'a
+
+  let id = fun x -> x
+  let x1to2 x2 fe fp x = x2 (fun _ e -> fe e) (fun p _ -> fp p) x
+
+  (* 2引数 *)
+  let v2 fe2 fp2 {pvb_pat = p; pvb_expr = e; pvb_attributes = a; pvb_loc = l} =
+    {pvb_pat = fp2 p e; pvb_expr = fe2 p e; pvb_attributes = a; pvb_loc = l}
+  let c2 fe2 fp2 {pc_lhs = p; pc_guard = g; pc_rhs = e} =
+    {pc_lhs = fp2 p e; pc_guard = g; pc_rhs = fe2 p e}
+
+  (* 1引数 *)
+  let v1 fe fp v = x1to2 v2 fe fp v
+  let c1 fe fp c = x1to2 c2 fe fp c
+  let e1 fe _ e = fe e
+  let p1 _ fp p = fp p
+  let le fe _ (l, e) = (l, fe e)
+  let lp _ fp (l, p) = (l, fp p)
+
+  (* 差し替え *)
+  let set_exp x1 x e = x1 (fun _ -> e) id x
+  let set_pat x1 x p = x1 id (fun _ -> p) x
+
+end
+
+(* ホール *)
+module Hole = struct
+
+  (* □の種類 *)
+  (* Exp : 式の□ *)
+  (* Pat : パターンの□ *)
+  (* Hole : 抽象化の必要がない *)
+  type t = Exp of attribute
+         | Pat of attribute
+         | Hole
+  (* □を求める関数 *)
+  (* Abst.hole' : ?exp:expression -> ?pat:pattern -> unit -> Abst.t *)
+  let rec hole' ?(exp = dummy_assertfalse ()) ?(pat = dummy_any ()) () =
+    match (exp, pat) with
+    | ({pexp_loc = loc; pexp_attributes = []}, _) when
+           exp <> dummy_assertfalse ~loc () && pat = dummy_any () ->
+       Exp ({txt = "exp"; loc}, PPat (pat, Some (exp))) (* 式の□ *)
+    | (_, {ppat_loc = loc; ppat_attributes = []}) when
+           exp = dummy_assertfalse () && pat <> dummy_any ~loc () ->
+       Pat ({txt = "pat"; loc}, PPat (pat, None)) (* パターンの□ *)
+    | _ -> Hole (* 既に抽象化されている *)
+  (* 式の抽象化 *)
+  (* Abst.expression : expression -> expression *)
+  and expression exp = match hole' ~exp () with
+    | Exp attr -> Exp.attr (dummy_assertfalse ~loc:exp.pexp_loc ()) attr
+    | _ -> exp
+  (* パターンの抽象化 *)
+  (* Abst.pattern : pattern -> pattern *)
+  and pattern pat = match hole' ~pat () with
+    | Pat attr -> Pat.attr (dummy_any ~loc:pat.ppat_loc ()) attr
+    | _ -> pat
+  (* ダミーの作成 *)
+  (* dummy_any : ~loc:loc -> unit -> pattern *)
+  (* その他 : ~loc:loc -> unit -> expression *)
+  and dummy_any ?(loc = Location.none) () =
+    Pat.any ~loc ()
+  and dummy_false ?(loc = Location.none) () =
+    Exp.construct ~loc (mknoloc (Longident.Lident "false")) None
+  and dummy_assertfalse ?(loc = Location.none) () =
+    Exp.assert_ ~loc (dummy_false ())
+  and dummy_int0 ?(loc = Location.none) () =
+    Exp.constant ~loc (Const.int 0)
+  and dummy_fun ?(loc = Location.none) () =
+    Exp.fun_ ~loc Nolabel None (dummy_any ()) (dummy_assertfalse ())
+
+  (* 変数として□を呼び出す用：lidになっている *)
+  let skeleton = mknoloc (Longident.parse "□")
+
+  (* □ を定義する structure_item *)
+  let item =
+    (* let □ = assert false *)
+    let p = Pat.var (mknoloc "□") in
+    let e = dummy_assertfalse () in
+    let vs = [Vb.mk p e] in
+    Str.value Nonrecursive vs
+
+  (* 式のホール *)
+  let hole_of_exp ({pexp_loc = loc; pexp_attributes = attrs} as exp) =
+    if List.exists (fun ({txt = name}, _) -> name = "exp") attrs
+    then exp (* 追加しなくて良い *)
+    else
+      let attrs = (mkloc "exp" loc, PStr [Str.eval ~loc exp]) :: attrs in
+      Exp.ident ~loc ~attrs skeleton
+
+(*
+    if attrs = [] then
+      let attrs = (mkloc "exp" loc, PStr [Str.eval ~loc exp]) :: attrs in
+      Exp.ident ~loc ~attrs skeleton
+    else exp
+ *)
+
+  (* パターンのホール *)
+  let hole_of_pat ({ppat_loc = loc; ppat_attributes = attrs} as pat) =
+    if List.exists (fun ({txt = name}, _) -> name = "pat") attrs
+    then pat (* 追加しなくて良い *)
+    else
+      let attrs = (mkloc "pat" loc, PPat (pat, None)) :: attrs in
+      Pat.any ~loc ~attrs ()
+(*
+    if attrs = [] then
+      let attrs = (mkloc "pat" loc, PPat (pat, None)) :: attrs in
+      Pat.any ~loc ~attrs ()
+    else pat
+ *)
+
+end
+
+let skeleton' = Exp.ident Hole.skeleton
+
+let hole_str = Hole.item
+let hole_of_exp exp = Hole.hole_of_exp exp
+let hole_of_pat pat = Hole.hole_of_pat pat
+
+module Desc = struct
+
+  type 'a make_exp_desc = 'a list -> expression -> expression_desc
+  type 'b make_pat_desc = 'b list -> pattern -> pattern_desc
+
+  (* open Abst *)
+  let skeleton = Exp.ident Hole.skeleton
+  let wildcard = Pat.any ()
+
+  (* expression : expression_desc -> expression -> expression *)
+  let expression desc {pexp_loc = loc; pexp_attributes = attrs} =
+    Exp.mk ~loc ~attrs desc
+
+  (* pattern : pattern_desc -> pattern -> pattern *)
+  let pattern desc {ppat_loc = loc; ppat_attributes = attrs} =
+    Pat.mk ~loc ~attrs desc
+
+  (* to_exp :
+      ('a list -> expression -> expression_desc)
+    -> 'a list -> expression -> expression -> expression *)
+  let to_exp fd xs e exp = expression (fd xs e) exp
+
+  (* to_pat :
+      ('a list -> pattern -> pattern_desc)
+    -> 'a list -> pattern -> pattern -> pattern *)
+  let to_pat fd ys p pat = pattern (fd ys p) pat
+
+  (* pexp_desc の生成 *)
+  let e_let flg vs e = Pexp_let (flg, vs, e)
+  let e_function cs _ = Pexp_function (cs)
+  let e_fun l eop p e = Pexp_fun (l, eop, p, e)
+  let e_apply les e = Pexp_apply (e, les)
+  let e_match cs e = Pexp_match (e, cs)
+  let e_try cs e = Pexp_try (e, cs)
+  let e_tuple es _ = Pexp_tuple (es)
+  let e_construct lid es e =
+    if es = [] then Pexp_construct (lid, Some e)
+    else if e = skeleton then Pexp_construct (lid, None)
+    else Pexp_construct (lid, Some (to_exp e_tuple es e e))
+  let e_variant l _ e = Pexp_variant (l, Some e)
+  let e_record les e =
+    if e = skeleton then Pexp_record (les, None)
+    else Pexp_record (les, Some e)
+  let e_field lid _ e = Pexp_field (e, lid)
+  let e_setfield lid e1 e2 = Pexp_setfield (e1, lid, e2)
+  let e_array es _ = Pexp_array (es)
+  let e_constraint ct _ e = Pexp_constraint (e, ct)
+  let e_ifthenelse e1 e2 eop = Pexp_ifthenelse (e1, e2, eop)
+  let e_sequence e1 e2 = Pexp_sequence (e1, e2)
+
+  (* ppat_desc の生成 *)
+  let p_alias str _ p = Ppat_alias (p, str)
+  let p_tuple ps _ = Ppat_tuple (ps)
+  let p_construct lid ps p =
+    if ps = [] then Ppat_construct (lid, Some p)
+    else if p = wildcard then Ppat_construct (lid, None)
+    else Ppat_construct (lid, Some (to_pat p_tuple ps p p))
+  let p_variant l _ p = Ppat_variant (l, Some p)
+  let p_record flg lps _ = Ppat_record (lps, flg)
+  let p_array ps _ = Ppat_array (ps)
+  let p_or p1 p2 = Ppat_or (p1, p2)
+  let p_constraint ct _ p = Ppat_constraint (p, ct)
+
+end
+
+module Abst = struct
+
+  let hole_of_x map1 x = map1 hole_of_exp (fun p -> p) x
+
+  (* set_one : slice -> slice list *)
+  (* 部分的に抽象化 *)
+  let set_one exp =
+
+    let sn n en sel = if sel = n then hole_of_exp en else en in
+
+    (* リストが構文中にない場合 *)
+    (* e が □ でなければ exp の desc を置き換えた要素を abst に追加 *)
+    let set_some e ?(abst = []) desc =
+      
+      if e = hole_of_exp e then abst
+      else abst @ [Desc.expression desc exp] in
+
+    (* リストが構文中にある場合 *)
+    (* 再帰で要素をひとつひとつ抽象化 *)
+    let set_one' ?(es = []) ?(e = skeleton') map1 fd xs =
+     
+      let to_exp fd e xs = Desc.to_exp fd xs e exp in
+      let fde acc = List.map (to_exp fd e) (List.rev acc) in
+      let dummy_apply es =
+        Desc.e_apply (List.map (fun e -> (Nolabel, e)) es) skeleton' in
+      let rec set_some' acc forward backword = match backword with
+       | [] -> fde acc
+       | tar :: backword' ->
+          (* チェック済 *)
+          let forward' = forward @ [tar] in
+          (* tar を□で置き換えることを試みる *)
+          let dummy = hole_of_x map1  tar in
+          let acc' =
+            if tar = dummy then acc
+            else (forward @ (dummy :: backword')) :: acc in
+          set_some' acc' forward' backword' in
+
+      set_some
+        e ~abst:(set_some' [] [] xs)
+        (if es = [] then fd xs (hole_of_exp e) else dummy_apply es) in
+    
+    (* abst_one のメイン部分 *)
+    match exp.pexp_desc with
+
+    | Pexp_let (flg, vs, e) ->
+       (* let 文 *)
+       (* let x = S1 in S2 => [let x = □ in S2; let x = S1 in □] *)
+       set_one' ~e Map.v1 (Desc.e_let flg) vs
+
+    | Pexp_apply (e, les) ->
+       (* 関数適用 *)
+       (* @ S1 .. Sn => [=@ S1..Sn; @ □..Sn; ...; @ S1..□]  *)
+       set_one' ~e Map.le Desc.e_apply les
+
+    | Pexp_function (cs) ->
+       (* function *)
+       (* function P1 -> S1 | ... | Pn -> Sn =>
+       [function P1 -> □ | ... ; function ... | Pn -> □] *)
+       set_one' Map.c1 Desc.e_function cs
+
+    | Pexp_fun (l, eop, p, e) ->
+       (* fun *)
+       (* λx.S => λx.□ *)
+      set_one' ~e Map.e1 (fun _ e -> Desc.e_fun l eop p e) []
+
+    | Pexp_match (e, cs) ->
+       (* match 文 *)
+       (* パターンする式と結果のみを対象にしている *)
+       (* match S0 with P1 -> S1 | ... | Pn -> Sn =>
+       [match □ with ...; ... with P1 -> □ | ...; ... with ... | Pn -> □] *)
+       set_one' ~e Map.c1 Desc.e_match cs
+                
+    | Pexp_try (e, cs) ->
+       (* try 文 *)
+       (* パターンする式と結果のみを対象にしている *)
+       (* try S0 with P1 -> S1 | ... | Pn -> Sn =>
+       [try □ with ...; ... with P1 -> □ | ...; ... with ... | Pn -> □] *)
+       set_one' ~e Map.c1 Desc.e_try cs
+                
+    | Pexp_tuple (es) ->
+       (* tuple *)
+       (* (S1, ... Sn) => [(□, ... Sn); ... ; (S1, ..., □); @= S1 ,..., Sn] *)
+       set_one' ~es Map.e1 Desc.e_tuple es
+                
+    | Pexp_construct (lid, Some (e)) ->
+       (* コンストラクタ *)
+       (* 引数が単数か複数かで分岐 *)
+       let es = match e.pexp_desc with
+           Pexp_tuple es -> es
+         | _ -> [] in
+       set_one' ~es ~e Map.e1 (Desc.e_construct lid) es
+                
+    | Pexp_record (les, eop) ->
+       (* record *)
+       (* 各フィールドを対象にしている *)
+       set_one'
+         ~e:(match eop with None -> skeleton' | Some e -> e)
+         Map.le Desc.e_record les
+         
+    | Pexp_field (e, lid) ->
+       set_one' ~e Map.e1 (Desc.e_field lid) []
+
+    | Pexp_setfield (e1, lid, e2) ->
+       let fd sel = Desc.e_setfield lid (sn 1 e1 sel) (sn 2 e2 sel) in
+       set_some ~abst:(set_some e1 (fd 1)) e2 (fd 2)
+
+    | Pexp_array (es) ->
+       (* array *)
+       set_one' ~es Map.e1 Desc.e_array es
+                
+    | Pexp_ifthenelse (e1, e2, eop) ->
+       (* ifthenelse *)
+       (* [if □ then e2 else e3;
+          if e1 then □ else e3;
+          if e1 then e2 else □] *)
+      let e3 = match eop with
+          Some e -> e | None -> skeleton' in
+      let fd sel = Desc.e_ifthenelse
+                     (sn 1 e1 sel) (sn 2 e2 sel)
+                     (if eop <> None && sel = 3
+                      then Some (hole_of_exp e3) else eop) in
+      set_some
+        ~abst:(set_some ~abst:(set_some e1 (fd 1)) e2 (fd 2)) e3 (fd 3)
+
+   | Pexp_sequence (e1, e2) ->
+      let fd sel = Desc.e_sequence (sn 1 e1 sel) (sn 2 e2 sel) in
+      set_some ~abst:(set_some e1 (fd 1)) e2 (fd 2)
+
+   | Pexp_constraint (e, c) ->
+      (* constraint *)
+      (* [(□ : c)] *)
+      set_one' ~e Map.e1 (Desc.e_constraint c) []
+
+   | _ -> if exp = hole_of_exp exp then [] else [hole_of_exp exp]
+
+  (* 部分式を全て抽象化 *)
+  let set_all exp =
+
+    let set_all' ?(e = skeleton') map1 fd xs =
+      Desc.to_exp fd (List.map (hole_of_x map1) xs) (hole_of_exp e) exp in
+    let set_all'' desc = Desc.expression desc exp in 
+
+    match exp.pexp_desc with
+
+    | Pexp_let (flg, vs, e) ->
+       set_all' ~e Map.v1 (Desc.e_let flg) vs
+
+    | Pexp_apply (e, les) ->
+       set_all' ~e Map.le Desc.e_apply les
+
+    | Pexp_function (cs) ->
+       set_all' Map.c1 Desc.e_function cs
+
+    | Pexp_fun (l, eop, p, e) ->
+       set_all'' (Desc.e_fun l eop p (hole_of_exp e))
+
+    | Pexp_match (e, cs) ->
+       set_all' ~e Map.c1 Desc.e_match cs
+
+    | Pexp_try (e, cs) ->
+       set_all' ~e Map.c1 Desc.e_try cs
+
+    | Pexp_tuple (es) ->
+       set_all' Map.e1 Desc.e_tuple es
+
+    | Pexp_construct (lid, Some e) ->
+       let es = match e.pexp_desc with
+           Pexp_tuple es -> es | _ -> [] in
+       set_all' ~e Map.e1 (Desc.e_construct lid) es
+
+    | Pexp_record (les, eop) ->
+       set_all' ~e:(match eop with None -> skeleton' | Some e -> e)
+                Map.le Desc.e_record les
+
+    | Pexp_field (e, lid) ->
+       set_all' ~e Map.e1 (Desc.e_field lid) []
+
+    | Pexp_array (es) ->
+       set_all' Map.e1 Desc.e_array es
+
+    | Pexp_ifthenelse (e1, e2, eop) ->
+       set_all'' (
+           Desc.e_ifthenelse (hole_of_exp e1)
+                             (hole_of_exp e2)
+                             (match eop with Some e3 -> Some (hole_of_exp e3)
+                                           | None -> None))
+
+    | Pexp_sequence (e1, e2) ->
+       set_all'' (
+           Desc.e_sequence (hole_of_exp e1)
+                           (hole_of_exp e2))
+
+    | Pexp_constraint (e, ct) ->
+       set_all' ~e Map.e1 (Desc.e_constraint ct) []
+
+    | d -> set_all'' d
+
+end
+
+module Size = struct
+
+  let set_size = false
+
+  (* size を求める関数 *)
+  let size n (_, payload) = match payload with
+      Size m -> m + n | _ -> n
+
+  (* size を得る関数 *)
+  (* get :?n:int ->  expression -> int *)
+  let get ?(n = 1) {pexp_attributes = attrs} =
+    List.fold_left size n attrs
+
+  (* size を与える関数 *)
+  (* set_one : ?n:int -> expression -> expression *)
+  let set_one ?(n = 1) slice =
+    if set_size then
+      Exp.attr slice (mknoloc "size", Size n)
+    else slice
+
+  (* set_all : ('a list -> 'a list -> expression ->
+                 ('a list -> expression -> expression_desc) -> expression)
+                -> ('a list -> expression -> expression_desc)
+                -> ('a -> expression) -> 'a list -> expression
+                -> expression *)
+  let set_all fp fd fx acc s_all =
+    if set_size then
+      let n = List.fold_left
+                (fun n x -> get ~n (fx x))
+                (get s_all) acc in
+      set_one ~n (fp acc [] s_all fd)
+    else (fp acc [] s_all fd)
+
+
+  let rec set expr =
+
+    let set_one n desc =
+      set_one ~n (Desc.expression desc expr) in
+
+    let set_all ?(e = skeleton') map1 fx fd xs =
+      (* サイズを求めつつリスト部分を更新 *)
+      let e' = set e in
+      let (n, xs') =
+        List.fold_left
+          (fun (n, acc) x ->
+            let en' = set (fx x) in
+            (get ~n en', acc @ [Map.set_exp map1 x en'])
+          ) (get e', []) xs in
+      set_one n (fd xs' e') in
+
+    match expr.pexp_desc with
+    (* とりあえず let sum x y = x + y in sum 1 2.でチェックする用に *)
+
+    | Pexp_let (flg, vs, e) ->
+       set_all ~e Map.v1 (fun v -> v.pvb_expr) (Desc.e_let flg) vs
+
+    | Pexp_apply (e, les) ->
+       set_all ~e Map.le snd Desc.e_apply les
+
+    | Pexp_fun (l, eop, p, e) ->
+       let e' = set e in
+       set_one (get e') (Desc.e_fun l eop p e')
+
+    | d -> set_one 1 d
+
+
+  let compare_size m e1 e2 =
+    compare (abs (m - get ~n:0 e1)) (abs (m - get ~n:0 e2))
+(*
+  let half_size_child m es e =
+    List.fold_left (
+        fun e1 e2 ->
+        if 0 < compare_size m e1 e2 then e2 else e1
+      ) e es
+ *)
+  (* 親ノードのサイズを取得して、子ノードの式を半分に近い順に並び替える *)
+  let node_sort expr =
+
+    let m = (1 + get expr) / 2 in (* 親のサイズの半分 *)
+    let sort_size es = List.stable_sort (compare_size m) es in
+
+    match expr.pexp_desc with
+    | Pexp_let (_, vs, e) ->
+       sort_size (e :: List.map (fun v -> v.pvb_expr) vs)
+    | Pexp_function (cs) ->
+       sort_size (List.map (fun c -> c.pc_rhs) cs)
+    | Pexp_fun (_, eop, _, e) ->
+       sort_size (match eop with None -> [e] | Some e' ->[e; e'])
+    | Pexp_apply (e, les) ->
+       sort_size (e :: List.map snd les)
+    | Pexp_match (e, cs) ->
+       sort_size (e :: List.map (fun c -> c.pc_rhs) cs)
+    | Pexp_try (e, cs) ->
+       sort_size (e :: List.map (fun c -> c.pc_rhs) cs)
+    | Pexp_tuple (es) -> sort_size es
+    | Pexp_construct (_, Some {pexp_desc = Pexp_tuple es}) -> sort_size es
+    | Pexp_construct (_, Some e) -> [e]
+    | Pexp_variant (_, Some e) -> [e]
+    | Pexp_record (les, eop) ->
+       sort_size ((List.map snd les)
+                  @ match eop with None -> [] | Some e -> [e])
+    | Pexp_field (e, _) -> [e]
+    | Pexp_setfield (e1, _, e2) -> sort_size [e1; e2]
+    | Pexp_array (es) -> sort_size es
+    | Pexp_ifthenelse (e1, e2, eop) ->
+       sort_size (e1 :: e2
+                  :: match eop with None -> [] | Some e3 -> [e3])
+    | Pexp_sequence (e1, e2) -> sort_size [e1; e2]
+    | Pexp_constraint (e, _) -> [e]
+    | Pexp_send (e, _) -> [e] 
+    | _ -> []
+
+end
+
+
+(* デバッグ用 *)
+module Meta = struct
+  (* 型デバッガが訪れるノード数カウント用の変数 (debug_main.ml) *)
+
+  let print_node_count =
+    false (* ノード数をカウントするときには true にする *)
+  (* true にすると型デバッグはできなくなる *)
+
+  let print_asked_expr =
+    false (* カウントされた質問を表示するときには true にする *)
+  (* スライス表示用変数 (debug_slice.ml) *)
+
+  let print_slice =
+    not print_node_count && (* ノード数カウント中はスライスを表示しない *)
+      false (* スライス結果を表示するときに true にする *)
+        
+  (* OCaml のエラーメッセージ Errors.report_error 制御用変数
+   (toplevel/toploop.ml, driver/compile.ml) *)
+        
+  let print_ocaml_error =
+    not print_node_count && (* ノード数カウント中は表示しない *)
+      true  (* OCaml のエラーメッセージを消すときに false にする *)
+
+  (* スライスをするかどうかを制御する変数
+   (debug_slice.ml, debug_main.ml) *)     
+  let on_exp_slice =
+    print_node_count || (* ノード数カウント中はスライスを行う *)
+      true (* スライスをしないときには false を代入する *)
+        
+  let on_pat_slice =
+    ref true (* パターンのスライスをしないときには false を代入する *)
+
+  let visible = false
+
+  let rec attribute ppf (kind, attrs) = match attrs with
+      [] -> ()
+    | ({txt = s}, PStr [{pstr_desc = Pstr_eval (e, _)}]) :: _ when s = kind ->
+       (* 式のホール □ *)
+       if visible then Format.fprintf ppf "【%a】" Pprintast.expression e
+       else Format.fprintf ppf "□"
+    | ({txt = s}, PPat (p, _)) :: _ when s = kind ->
+       (* パターンのホール ■ *)
+       if visible then Format.fprintf ppf "【%a】" Pprintast.pattern p
+       else Format.fprintf ppf "■"
+    | ({txt = s}, Size n) :: _ when s = kind ->
+       (* サイズ *)
+       Format.fprintf ppf "(size : %d)" n
+    | _ :: rest-> attribute ppf (kind, rest)
+
+  (* 表示 *)
+  (* expression -> unit *)
+  and expression ppf ({pexp_desc = d; pexp_attributes = attrs} as exp) =
+    match d with
+    | Pexp_let (flg, vs, e) -> pexp_let ppf (flg, vs, Some (e))
+    | Pexp_fun (_, _, p, e) -> pexp_fun ppf (p, e)
+    | Pexp_apply (e, les) -> pexp_apply ppf (e, les)
+    | Pexp_match (e, cs) -> pexp_match ppf (e, cs)
+    | Pexp_try (e, cs) -> pexp_try ppf (e, cs)
+    | Pexp_tuple es -> pexp_tuple ppf es
+    | Pexp_construct (lid, Some (e)) -> pexp_construct ppf (lid, e)
+    | Pexp_record (les, _) -> pexp_record ppf les
+    | Pexp_array (es) -> pexp_array ppf es
+    | Pexp_ifthenelse (e1, e2, eop) -> pexp_ifthenelse ppf (e1, e2, eop)
+    | _ -> if exp = hole_of_exp exp then attribute ppf ("exp", attrs)
+           else Pprintast.expression ppf (Exp.mk d)
+
+  and value_binding ppf {pvb_pat = pn; pvb_expr = en} = match en.pexp_desc with
+    | Pexp_fun (_, _, p, e) ->
+       Format.fprintf ppf "%a %a"
+                      pattern pn
+                      value_binding (Vb.mk p e)
+    | _ ->
+       Format.fprintf ppf "%a = %a"
+                      pattern pn
+                      expression en
+
+
+  and cases ppf cs =
+    let case ppf {pc_lhs = pn; pc_guard = gn; pc_rhs = en} = match gn with
+      | None ->
+         Format.fprintf ppf "| %a -> %a"
+                        pattern pn
+                        expression en
+      | Some (e) ->
+         Format.fprintf ppf "| %a when %a -> %a"
+                        pattern pn
+                        expression e
+                        expression en in
+    List.iter (fun c -> Format.fprintf ppf "%a" case c) cs
+
+  and field_and_exp ppf (l, e) =
+    Format.fprintf ppf "%s = %a; "
+                   (Longident.last l.txt)
+                   expression e
+
+  and es_tl ppf (s, tl) =
+    List.iter (
+        fun en ->
+        Format.fprintf ppf "%s %a" s
+                       expression en) tl
+
+  and pexp_let ppf (flg, vs, eop) = match vs with
+      [] -> assert false
+    | first :: rest ->
+       let vb_hd ppf hd =
+         Format.fprintf ppf (if flg = Recursive
+                             then "let rec %a"
+                             else "let %a") value_binding hd in
+       let vb_tl ppf tl =
+         List.iter (
+             fun vn ->
+             Format.fprintf ppf " and %a" value_binding vn) tl in
+       match eop with
+       | None ->
+          Format.fprintf ppf "%a %a"
+                         vb_hd first
+                         vb_tl rest
+       | Some (e) ->
+          Format.fprintf ppf "%a %a in %a"
+                         vb_hd first
+                         vb_tl rest
+                         expression e
+
+  and pexp_fun ppf (p, e) =
+    Format.fprintf ppf "(fun %a -> %a)"
+                   pattern p
+                   expression e
+
+  and pexp_apply ppf (e, les) =
+    let args ppf les =
+      List.iter (fun (_, e) -> Format.fprintf ppf " %a" expression e) les in
+    Format.fprintf ppf "(%a%a)"
+                   expression e
+                   args les
+
+  and pexp_match ppf (e, cs) =
+    Format.fprintf ppf "match %a with %a"
+                   expression e
+                   cases cs
+
+  and pexp_try ppf (e, cs) =
+    Format.fprintf ppf "try %a with %a"
+                   expression e
+                   cases cs
+
+  and pexp_tuple ppf es = match es with
+      [] -> assert false
+    | first :: rest ->
+       Format.fprintf ppf "(%a%a)"
+                      expression first
+                      es_tl (",", rest)
+
+  and pexp_construct ppf (lid, e) = (* 要素ありのみ *)
+    Format.fprintf ppf "(%s %a)"
+                   (Longident.last lid.txt)
+                   expression e
+
+  and pexp_record ppf les =
+    Format.fprintf ppf "{%a}"
+                   (fun ppf les ->
+                     List.iter (field_and_exp ppf) les) les
+
+  and pexp_array ppf es = match es with
+      [] -> Format.fprintf ppf "[||]"
+    | first :: rest ->
+       Format.fprintf ppf "[|%a%a|]"
+                      expression first
+                      es_tl (";", rest)
+
+  and pexp_ifthenelse ppf (e1, e2, eop) = match eop with
+    | None ->
+       Format.fprintf ppf "@if %a then %a"
+                      expression e1
+                      expression e2
+    | Some (e3) ->
+       Format.fprintf ppf "if %a then %a else %a"
+                      expression e1
+                      expression e2
+                      expression e3
+
+  and pattern ppf ({ppat_desc = d; ppat_attributes = attrs} as pat) =
+    match d with
+    | Ppat_tuple ps -> ppat_tuple ppf ps
+    | Ppat_construct (lid, Some (p)) -> ppat_construct ppf (lid, p)
+    | Ppat_record (lps, _) -> ppat_record ppf lps
+    | _ -> if pat = hole_of_pat pat then attribute ppf ("pat", attrs)
+           else Pprintast.pattern ppf pat
+
+  and ppat_tuple ppf ps = match ps with
+      [] -> assert false
+    | first :: rest ->
+       Format.fprintf
+         ppf "(%a%a)"
+         pattern first
+         (fun ppf ps ->
+           List.iter (Format.fprintf ppf ", %a" pattern) ps) rest
+
+  and ppat_construct ppf (lid, p) = (* 要素ありのみ *)
+    Format.fprintf ppf "(%s %a)"
+                   (Longident.last lid.txt)
+                   pattern p
+
+  and ppat_record ppf lps =
+    Format.fprintf ppf "{%a}"
+                   (fun ppf lps ->
+                     List.iter (field_and_pat ppf) lps) lps
+
+  and field_and_pat ppf (l, p) =
+    Format.fprintf ppf "%s = %a; "
+                   (Longident.last l.txt) pattern p
+
+  let rec structure ppf str = match str with
+    | [] -> ()
+    | ({pstr_desc = d} as first) :: rest ->
+       (* first の表示 *)
+       if first <> hole_str then
+         match d with
+         | Pstr_eval (e, _) ->
+            Format.fprintf ppf "@[%a@]@." expression e
+         | Pstr_value (flg, vs) ->
+            Format.fprintf ppf "@[%a@]@." pexp_let (flg, vs, None)
+         | _ ->
+            Format.fprintf ppf "@[%a@]@." Pprintast.structure [first]
+       else Format.fprintf ppf "@[(The mark '□' is a hole expression.)@]@.";
+       (* rest について再帰 *)
+       Format.fprintf ppf "@[%a@]@." structure rest
+
+  (* デバッグ用 expression の print *)
+  let print_deb_exp ppf exp =
+    Format.fprintf ppf "%a %a"
+                   expression exp
+                   attribute ("size", exp.pexp_attributes)
+  let print_deb_strs ppf strs = Format.fprintf ppf "%a"structure strs
+
+end
+
+(*
+(* 位置情報付き dummy_false *)
+let dummy_false loc = {
+  pexp_desc       = Pexp_construct (mknoloc (Longident.Lident "false"), None);
+  pexp_loc        = loc;
+  pexp_attributes = [];
+}
+
+
+(* スケルトン *)
+let skeleton = {
+  pexp_desc       = Pexp_assert (dummy_false Location.none);
+  pexp_loc        = Location.none;
+  pexp_attributes = [];
+}
+let wildcard = {
+    ppat_desc = Ppat_any;
+    ppat_loc = Location.none;
+    ppat_attributes = [];
+  }
+
+(* □を示すattribute：exp, pat共通 *)
+(* pat にワイルドカードを渡すと exp の□ *)
+(* exp にスケルトンを渡すと pat の□ *)
+let hole exp pat =
+  let str_loc =
+    if pat = wildcard then
+      {txt = "exp"; loc = exp.pexp_loc}
+    else if exp = skeleton then
+      {txt = "pat"; loc = pat.ppat_loc}
+    else assert false in
+  let p_payload = PPat (pat, if exp = skeleton then None else Some exp) in
+  (str_loc, p_payload)
+
+(* 省略前の式情報付き dummy_assertfalse *)
+let dummy_assertfalse exp =
+  if exp.pexp_desc = Pexp_assert (dummy_false exp.pexp_loc)
+  then exp
+  else {
+      pexp_desc       = Pexp_assert (dummy_false exp.pexp_loc);
+      pexp_loc        = exp.pexp_loc;
+      pexp_attributes = hole exp wildcard :: [];
+    }
+
+(* 省略前のパターン情報付き any *)
+let dummy_any pat =
+  if pat.ppat_desc = Ppat_any
+  then pat
+  else {ppat_desc = Ppat_any;
+        ppat_loc = pat.ppat_loc;
+        ppat_attributes = hole skeleton pat :: [];
+       }
+
+let dummy_int0 = Exp.mk (Pexp_constant (Pconst_integer ("0", None)))
+
+let dummy_fun = Exp.mk (Pexp_fun (Nolabel, None, wildcard, skeleton))
+ *)
+
+(* 抽象：変数 *)
+let skeleton = Hole.dummy_assertfalse ()
+let wildcard = Hole.dummy_any ()
+let dummy_int0 = Hole.dummy_int0 ()
+let dummy_fun = Hole.dummy_fun ()
+(* 抽象化：関数 *)
+let dummy_assertfalse exp = Hole.expression exp
+let dummy_any pat = Hole.pattern pat
+
+(* デバッグ用：変数 *)
+(* 表示の切り替え *)
+let print_node_count = Meta.print_node_count
+let print_asked_expr = Meta.print_asked_expr
+let print_slice = Meta.print_slice
+let print_ocaml_error = Meta.print_ocaml_error
+(* スライスの切り替え *)
+let on_slice = Meta.on_exp_slice
+let on_pat_slice = Meta.on_pat_slice
+(* デバッグ用：関数 *)
+let print_deb_exp ppf exp = Meta.print_deb_exp ppf exp
+let print_deb_strs ppf strs = Meta.print_deb_strs ppf strs
+
+(*
+let print_node_count =
+  false (* ノード数をカウントするときには true にする *)
+        (* true にすると型デバッグはできなくなる *)
+let print_asked_expr =
+  false (* カウントされた質問を表示するときには true にする *)
+
+(* スライス表示用変数 (debug_slice.ml) *)
+
+let print_slice =
+  not print_node_count && (* ノード数カウント中はスライスを表示しない *)
+  false (* スライス結果を表示するときに true にする *)
+
+(* OCaml のエラーメッセージ Errors.report_error 制御用変数
+   (toplevel/toploop.ml, driver/compile.ml) *)
+
+let print_ocaml_error =
+  not print_node_count && (* ノード数カウント中は表示しない *)
+  true  (* OCaml のエラーメッセージを消すときに false にする *)
+
+(* スライスをするかどうかを制御する変数
+   (debug_slice.ml, debug_main.ml) *)
+
+let on_slice =
+  print_node_count || (* ノード数カウント中はスライスを行う *)
+  true (* スライスをしないときには false を代入する *)
+
+let on_pat_slice =
+  ref true (* パターンのスライスをしないときには false を代入する *)
+ *)
+
+(* ---------------------------------------------------------- *)
+(* デバッガ、スライサ共通の定義 *)
+
+let rec get_type_name typ = match typ.desc with
+  | Tconstr (path, _, _) ->
+     (* 定義名とモジュール名のリストを返す *)
+     let lst =
+       (Longident.flatten (Longident.parse (Path.name path))) in
+     List.fold_left (
+         fun (type_name, mod_names) s ->
+         (s, if type_name = "" then mod_names
+             else type_name :: mod_names)
+       ) ("", []) lst
+  | Tsubst (t) -> get_type_name t
+  | Tlink (t) -> get_type_name t
+  | _ -> assert false
+
+let rec get_type_decl (type_name, mod_names) prefix = match prefix with
+    [] -> failwith "this type was not find."
+  | ({pstr_desc = d}, _) :: rest ->
+     match d with
+     | Pstr_module ({pmb_name = {txt = name};
+                     pmb_expr = {pmod_desc =
+                                   Pmod_structure (mod_str)}}) ->
+        (* モジュールの定義 *)
+        (* name が mod_names にある場合は mod_str も再帰に含める *)
+        get_type_decl
+          (type_name, mod_names)
+          (if List.exists (
+                  fun mod_name -> mod_name = name) mod_names
+           then List.fold_left (
+                    fun rest' s -> (s, Env.empty) :: rest'
+                  ) rest mod_str else rest)
+     | Pstr_type (_, tds) ->
+        (* 型の定義 *)
+        (* 名前が一致した場合に type_declaration を返す *)
+        begin
+          try
+            let td =
+              List.find (fun {ptype_name = {txt = name}} ->
+                          name = type_name) tds in
+            if print_slice then
+              Format.fprintf ppf "@[  find type_declaration. @]@.";
+            td
+          with _ -> get_type_decl (type_name, mod_names) rest
+        end
+     | _ -> get_type_decl (type_name, mod_names) rest
+    
+(* decode_labels : type_expr -> prefix -> label_declaration list *)
+let decode_labels typ prefix =
+  match get_type_decl (get_type_name typ) prefix with
+  | {ptype_kind = Ptype_record (lds)} -> lds
+  | _ -> failwith "This type is not record."
+
+(* 矢印の分離 *)
+(* split_arrow : type_expr -> (type_expr * type_expr) option *)
+let rec split_arrow typ = match typ.desc with
+    Tarrow (_, t1, t2, _) -> Some (t1, t2)
+  | Tlink (typ') -> split_arrow typ'
+  | _ -> None
+
+(* タプルの分離 *)
+(* decode_tuple : type_expr -> type_expr option *)
+let rec decode_tuple typ = match typ.desc with
+    Ttuple (typs) -> Some (typs)
+  | Tlink (typ') -> decode_tuple typ'
+  | _ -> None
+
+(* ---------------------------------------------------------- *)
+(* 構文の生成 *)
+
+(* 元の構文の desc を置き換える *)
+let desc_to_exp = Desc.expression
+let desc_to_pat = Desc.pattern
+
+(*
+(* desc_to_exp : expression_desc -> expression -> expression *)
+let desc_to_exp desc {pexp_loc = loc; pexp_attributes = attrs} =
+  Exp.mk ~loc ~attrs desc
+(*
+  {pexp_desc = desc; pexp_loc = exp.pexp_loc; pexp_attributes = exp.pexp_attributes} *)
+(* desc_to_pat : pattern_desc -> pattern -> pattern *)
+let desc_to_pat desc {ppat_loc = loc; ppat_attributes = attrs} =
+  Pat.mk ~loc ~attrs desc
+(*
+  {ppat_desc = desc; ppat_loc = pat.ppat_loc; ppat_attributes = pat.ppat_attributes} *)
+ *)
+
+(* ---------------------------------------------------------- *)
+
+
+(* pattern_variables : pattern -> string list *)
+(* collect all the pattern variables in a pattern *)
+let rec pattern_variables pat = match pat.ppat_desc with
+    Ppat_any -> []
+  | Ppat_var ({txt = st}) -> [st]
+  | Ppat_alias (p, {txt = st}) -> st :: pattern_variables p
+  | Ppat_constant (_) -> []
+  | Ppat_interval (_, _) -> []
+  | Ppat_tuple (ps) -> List.flatten (List.map pattern_variables ps)
+  | Ppat_construct (_, None) -> []
+  | Ppat_construct (_, Some (p)) -> pattern_variables p
+  | Ppat_variant (_, None) -> []
+  | Ppat_variant (_, Some (p)) -> pattern_variables p
+  | Ppat_record (lps, _) ->
+      List.flatten (List.map (fun (_, p) -> pattern_variables p) lps)
+  | Ppat_array (ps) -> List.flatten (List.map pattern_variables ps)
+  | Ppat_or (p1, p2) -> pattern_variables p1 @ pattern_variables p2
+  | Ppat_constraint (p, _) -> pattern_variables p
+  | Ppat_type (_) -> []
+  | Ppat_lazy (p) -> pattern_variables p
+  | Ppat_unpack ({txt = st}) -> [st]
+  | Ppat_exception (p) -> pattern_variables p
+  | Ppat_extension (_) -> []
+  | Ppat_open (_, p) -> pattern_variables p
+
+let rec plug_expr expr cxt = match cxt with
+  | Empty -> expr
+  | Lambda (pat, c) ->
+     (* パターン変数を全て集め *)
+     let vars = pattern_variables pat in
+     (* 変数名から変数の expression を作る *)
+     let varexp x = Exp.ident (mknoloc (Longident.Lident x)) in
+(*
+     let varexp x = Exp.mk (Pexp_ident (mknoloc (Longident.Lident x))) in *)
+     (* expr と組にして body に入れる。これでパターン変数の型を知る *)
+     (* ダミーの 0 を入れるのは、tuple 長が 2 以上でないとエラーになるため *)
+     let body = Exp.tuple (expr :: dummy_int0 :: List.map varexp vars) in
+     let exp = Exp.fun_ Nolabel None pat body in
+(*
+     let body = Exp.mk (Pexp_tuple
+                          (expr :: dummy_int0 :: List.map varexp vars)) in
+     let exp = Exp.mk (Pexp_fun (Nolabel, None, pat, body)) in *)
+     plug_expr exp c
+  | Let (flg, bindings, c) ->
+     let exp = Exp.let_ flg bindings expr in
+(*
+     let exp = Exp.mk (Pexp_let (flag, bindings, expr)) in
+
+{ pexp_desc        = Pexp_let (flag, bindings, expr);
+                  pexp_loc         = Location.none;
+                  pexp_attributes  = [] }*)
+     plug_expr exp c
+
+(* plug_str : (expression * expr_context) -> structure *)
+(*
+let plug_str (expr, cxt) = [Str.mk (Pstr_eval (plug_expr expr cxt, []))]
+ *)
+let plug_str (expr, cxt) = [Str.eval (plug_expr expr cxt)]
+(*
+  [{ pstr_desc = Pstr_eval (plug_expr expr cxt, []);
+     pstr_loc  = Location.none }]
+ *)
+
+(* collect_one : (string context_t * type_expr) context_t -> string list ->
+                 type_expr -> yes_no_list * type_expr *)
+let collect_one ((vartyps, cxt'), env, prefix) vars typ =
+  match decode_tuple typ with
+      Some (exp_typ :: _ :: typs) -> (* _ は dummy_int0 の型 *)
+        (List.map2 (fun v t -> (((v, cxt'), env, prefix), t)) vars typs
+         @ vartyps,
+         exp_typ)
+    | Some ([_]) | Some ([]) | None ->
+        Format.fprintf ppf "type:@.%a@." Printtyp.type_expr typ;
+        failwith "TypeDebugger: Error in collect_one"
+
+(* collect : expression context_t -> type_expr -> yes_no_list * type_expr *)
+let rec collect ((expr, cxt), env, prefix) t = match cxt with
+    Empty -> ([], t)
+  | Let (_, _, cxt') -> collect ((expr, cxt'), env, prefix) t
+  | Lambda (pat, cxt') ->
+      (* There and back again [Danvy&Goldberg ICFP'02] *)
+      let (vartyps, t') = collect ((expr, cxt'), env, prefix) t in
+      let vars = pattern_variables pat in
+      match split_arrow t' with
+          Some ((*t1*)_, t2) ->
+            collect_one ((vartyps, cxt'), env, prefix) vars t2
+        | None -> (* Can't happen *)
+            failwith "TypeDebugger: Error in collect"
+
+(* judge : expression context_t -> yes_no_list * type_expr *)
+let judge ((expr, cxt), env, prefix) =
+  let structure = plug_str (expr, cxt) in
+  let (structure', _, _) = Typemod.type_structure env structure Location.none in
+  match structure'.str_items with
+    {str_desc = Tstr_eval ({ exp_type = typ }, _)} :: [] ->
+      collect ((expr, cxt), env, prefix) typ
+  | _ -> failwith "TypeDebugger: Error in judge"
diff --git a/typing/debug_core.mli b/typing/debug_core.mli
new file mode 100755
index 0000000..5e4f649
--- /dev/null
+++ b/typing/debug_core.mli
@@ -0,0 +1,168 @@
+open Asttypes
+open Types
+
+open Parsetree
+
+(* ppf *)
+val ppf : Format.formatter
+
+(* コンテキストの定義 *)
+type expr_context =
+  | Empty
+  | Lambda of pattern * expr_context
+  | Let of rec_flag * value_binding list * expr_context
+type 'a context_t =
+  ('a * expr_context) * Env.t * (structure_item * Env.t) list
+
+(* module Map *)
+module Map : sig
+
+  type 'a map2 = (pattern -> expression -> expression)
+                 -> (pattern -> expression -> pattern)
+                 -> 'a -> 'a
+  type 'a map1 = (expression -> expression) -> (pattern -> pattern)
+                 -> 'a -> 'a
+
+  (* 与える関数が2引数 *)
+  val v2 : value_binding map2
+  val c2 : case map2
+
+  (* 与える関数が1引数 *)
+  val v1 : value_binding map1
+  val c1 : case map1
+  val e1 : expression map1
+  val p1 : pattern map1
+  val le : ('a * expression) map1
+  val lp : ('a * pattern) map1
+
+  (* exp / pat を差し替える *)
+  val set_exp : 'a map1 -> 'a -> expression -> 'a
+  val set_pat : 'a map1 -> 'a -> pattern -> 'a
+
+end
+
+(* module Desc *)
+module Desc : sig
+
+  (* 生成関数の型 *)
+  type 'a make_exp_desc = 'a list -> expression -> expression_desc
+  type 'b make_pat_desc = 'b list -> pattern -> pattern_desc
+
+  (* 生成関数を使って exp / pat の desc を差し替える *)
+  val to_exp : 'a make_exp_desc -> 'a list
+               -> expression -> expression -> expression
+  val to_pat : 'b make_pat_desc -> 'b list
+               -> pattern -> pattern -> pattern
+
+  (* pexp_desc の生成 *)
+  val e_let : rec_flag -> value_binding make_exp_desc
+  val e_function : case make_exp_desc
+  val e_fun : arg_label -> expression option
+              -> pattern -> expression -> expression_desc
+  val e_apply : (arg_label * expression) make_exp_desc
+  val e_match : case make_exp_desc
+  val e_try : case make_exp_desc
+  val e_tuple : expression make_exp_desc
+  val e_construct : Longident.t loc -> expression make_exp_desc
+  val e_variant : label -> expression make_exp_desc
+  val e_record : (Longident.t loc * expression) make_exp_desc
+  val e_field : Longident.t loc -> expression make_exp_desc
+  val e_setfield : Longident.t loc
+                   -> expression -> expression -> expression_desc
+  val e_array : expression make_exp_desc
+  val e_constraint : core_type -> expression make_exp_desc
+  val e_ifthenelse : expression -> expression
+                     -> expression option -> expression_desc
+  val e_sequence : expression -> expression -> expression_desc
+
+  (* ppat_desc の生成 *)
+  val p_alias : string loc -> pattern make_pat_desc
+  val p_tuple : pattern make_pat_desc
+  val p_construct : Longident.t loc -> pattern make_pat_desc
+  val p_variant : label -> pattern make_pat_desc
+  val p_record : closed_flag -> (Longident.t loc * pattern) make_pat_desc
+  val p_array : pattern make_pat_desc
+  val p_or : pattern -> pattern -> pattern_desc
+  val p_constraint : core_type -> pattern make_pat_desc
+
+end
+
+(* module Abst *)
+module Abst : sig
+  val set_one : expression -> expression list
+  val set_all : expression -> expression
+end
+
+(* module Size  *)
+module Size : sig
+
+  val get : ?n:int ->  expression -> int
+  val set_one : ?n:int -> expression -> expression
+  val set_all :
+    ('a list -> 'a list -> expression -> 'a Desc.make_exp_desc -> expression)
+    ->'a Desc.make_exp_desc -> ('a -> expression) -> 'a list -> expression
+    -> expression
+
+  val set : expression -> expression
+
+  val node_sort : expression -> expression list
+
+end
+
+
+(* 型デバッガが訪れるノード数カウント用の変数 (debug_main.ml) *)
+
+val print_node_count : bool
+val print_asked_expr : bool
+
+(* スライス表示用変数 (debug_slice.ml) *)
+
+val print_slice : bool
+
+(* OCaml のエラーメッセージ Errors.report_error 制御用変数
+   (toplevel/toploop.ml, driver/compile.ml) *)
+
+val print_ocaml_error : bool
+
+(* スライスをするかどうかを制御する変数
+   (debug_slice.ml, debug_main.ml) *)
+
+val on_slice : bool
+val on_pat_slice : bool ref
+
+(* 表示用関数 *)
+val print_deb_exp : Format.formatter -> expression -> unit
+val print_deb_strs : Format.formatter -> structure -> unit
+
+(* 抽象化した構文
+   (debug_slice.ml, debug_main.ml) *)
+val dummy_int0 : expression
+val skeleton : expression
+val wildcard : pattern
+val dummy_fun : expression
+val dummy_assertfalse : expression -> expression
+val dummy_any : pattern -> pattern
+
+(* desc の置換を行う関数 *)
+val desc_to_exp : expression_desc -> expression -> expression
+val desc_to_pat : pattern_desc -> pattern -> pattern
+
+(* type_expr を扱う関数 *)
+val decode_labels : type_expr -> (structure_item * Env.t) list -> label_declaration list
+val split_arrow : type_expr -> (type_expr * type_expr) option
+
+val decode_tuple : type_expr -> type_expr list option
+
+(* デバッガの処理を行う関数
+   (debug_slice.ml, debug_main.ml) *)
+val pattern_variables : pattern -> string list
+val plug_str : (expression * expr_context) -> structure
+
+val judge : expression context_t -> (string context_t * type_expr) list * type_expr 
+
+
+val skeleton' : expression
+val hole_str : structure_item
+
+val hole_of_exp : expression -> expression
+val hole_of_pat : pattern -> pattern
diff --git a/typing/debug_main.ml b/typing/debug_main.ml
new file mode 100644
index 0000000..8f9bbd1
--- /dev/null
+++ b/typing/debug_main.ml
@@ -0,0 +1,2654 @@
+open Asttypes
+open Ast_helper
+
+open Typedtree
+
+open Location
+open Parsetree
+
+open Debug_core
+open Debug_message
+
+let auto = false
+
+let skeleton = skeleton'
+
+(* skeleton : expression *)
+(* dummy_assertfalse : expression -> expression *)
+
+(* ppf : Format.formatter *)
+let ppf = Format.std_formatter
+
+(* language_level : int *)
+let language_level = Syntaxerr.language_level
+
+(* debug : int *)
+let debug = try
+  int_of_string (Sys.getenv "TRACE_DEBUGGER")
+with _ -> 0
+(* 0 : no trace *)
+(* 1 : overall progress *)
+(* 2 : illtyped *)
+(* 4 : recursive env *)
+(* 8 : make message illtyped *)
+
+exception DebuggerQuit
+
+(* find_funtype_args : type_expr list -> int -> (int * type_expr) list *)
+(* int は 何番目の引数かを記憶 *)
+let rec find_funtype_args lst n = match lst with
+    [] -> []
+  | typ :: rest ->
+      begin match split_arrow typ with
+          None -> find_funtype_args rest (n + 1)
+        | Some (_, _) -> (n, typ) :: find_funtype_args rest (n + 1)
+      end
+
+(********** pat_appears **********)
+
+(* pattern_variables : pattern -> string list *)
+(* collect all the pattern variables in a pattern *)
+(*
+let rec pattern_variables pat = match pat.ppat_desc with
+    Ppat_any -> []
+  | Ppat_var ({txt = st}) -> [st]
+  | Ppat_alias (p, {txt = st}) -> st :: pattern_variables p
+  | Ppat_constant (_) -> []
+  | Ppat_interval (_, _) -> []
+  | Ppat_tuple (ps) -> List.flatten (List.map pattern_variables ps)
+  | Ppat_construct (_, None) -> []
+  | Ppat_construct (_, Some (p)) -> pattern_variables p
+  | Ppat_variant (_, None) -> []
+  | Ppat_variant (_, Some (p)) -> pattern_variables p
+  | Ppat_record (lps, _) ->
+      List.flatten (List.map (fun (_, p) -> pattern_variables p) lps)
+  | Ppat_array (ps) -> List.flatten (List.map pattern_variables ps)
+  | Ppat_or (p1, p2) -> pattern_variables p1 @ pattern_variables p2
+  | Ppat_constraint (p, _) -> pattern_variables p
+  | Ppat_type (_) -> []
+  | Ppat_lazy (p) -> pattern_variables p
+  | Ppat_unpack ({txt = st}) -> [st]
+  | Ppat_exception (p) -> pattern_variables p
+  | Ppat_extension (_) -> []
+  | Ppat_open (_, p) -> pattern_variables p
+ *)
+
+(* pat_appears : string -> pattern -> bool *)
+let pat_appears st pat = List.mem st (pattern_variables pat)
+
+(********** expr_context **********)
+(*
+type expr_context =
+    Empty
+  | Lambda of pattern * expr_context
+    (* TODO: incorporate labeled arguments, currently ignored *)
+  | Let of rec_flag * value_binding list * expr_context
+ *)
+
+(* type of prefix: reversed list of structure and environment *)
+(* type str_context = (structure_item * Env.t) list *)
+
+(* type of contexts *)
+(* type 'a context_t = ('a * expr_context) * Env.t * str_context *)
+
+(* expression context_t 型の値 ((exp, cxt), env, lst) の意味は以下 *)
+(* env は (exp, cxt) を実行する際の環境 *)
+(* lst は (structure, env) の逆順のリストで env は structure 実行前の環境 *)
+
+(********** plug **********)
+(*
+(* plug_expr : expression -> expr_context -> expression *)
+let rec plug_expr expr cxt = match cxt with
+  | Empty -> expr
+  | Lambda (pat, c) ->
+      (* パターン変数を全て集め *)
+      let vars = pattern_variables pat in
+      (* 変数名から変数の expression を作る *)
+      let varexp x = Exp.mk (Pexp_ident (mknoloc (Longident.Lident x))) in
+      (* expr と組にして body に入れる。これでパターン変数の型を知る *)
+      (* ダミーの 0 を入れるのは、tuple 長が 2 以上でないとエラーになるため *)
+      let body = Exp.mk (Pexp_tuple
+                          (expr :: dummy_int0 :: List.map varexp vars)) in
+      let exp = Exp.mk (Pexp_fun (Nolabel, None, pat, body)) in
+      plug_expr exp c
+  | Let (flag, bindings, c) ->
+      plug_expr { pexp_desc        = Pexp_let (flag, bindings, expr);
+                  pexp_loc         = Location.none;
+                  pexp_attributes  = [] }
+                c
+
+(* plug_str : expression * expr_context -> structure *)
+let plug_str (expr, cxt) =
+  [{ pstr_desc = Pstr_eval (plug_expr expr cxt, []);
+     pstr_loc  = Location.none }]
+ *)
+
+(********** is_well_typed **********)
+
+(* is_well_typed_structure : structure -> Env.t -> bool *)
+(* Error = Location * Env * error になったので引数に env を加えた *)
+let is_well_typed_structure structure env =
+  try
+    ignore (Typemod.type_structure env structure Location.none);
+    (* Format.fprintf ppf "@[:welltyped@]@."; *)
+    true
+  with Typecore.Error (_, _, Typecore.Expr_type_clash (_))
+     | Typecore.Error (_, _, Typecore.Pattern_type_clash (_))
+     | _ (* Unbound value *)
+     ->
+       (* Format.fprintf ppf "@[:illtyped@]@."; *)
+       false
+
+(* is_well_typed_expr : expression context_t -> bool *)
+let is_well_typed_expr ((expr, cxt), env, _) =
+  is_well_typed_structure (plug_str (expr, cxt)) env
+
+(********** get **********)
+
+(* get_var_from_prefix : string -> str_context -> expression context_t list *)
+(* returns [] if not found; otherwise [((e, cxt), env, prefix)] *)
+let rec get_var_from_prefix st prefix = match prefix with
+    [] -> [] (* This happens when no binding is found, such as for '+' *)
+  | ({ pstr_desc = Pstr_value (flg, bindings) }, env) :: rest ->
+      (* let 文のみ考慮 *)
+      let rec loop bindings' = match bindings' with
+          [] -> get_var_from_prefix st rest
+        | {pvb_pat = p; pvb_expr = e} :: rest' ->
+            if pat_appears st p then
+              if flg = Recursive
+              then (* 定義された全ての変数が見えている *)
+                let cxt' = List.fold_right
+                             (fun {pvb_pat = pat} c -> Lambda (pat, c))
+                             bindings Empty in
+                [((e, cxt'), env, prefix)]
+              else [((e, Empty), env, rest)]
+            else loop rest'
+      in loop bindings
+  | _ :: rest ->
+      get_var_from_prefix st rest
+
+(* get_var_from_context : string context_t -> expression context_t list *)
+(* returns [] if not found; otherwise [((e, cxt), env, prefix)] *)
+let rec get_var_from_context ((st, cxt), env, prefix) = match cxt with
+    Empty -> get_var_from_prefix st prefix
+  | Lambda (p, cxt') -> (* もし p に現れていたら、その変数の定義はない *)
+      if pat_appears st p then []
+      else get_var_from_context ((st, cxt'), env, prefix)
+  | Let (flg, bindings, cxt') ->
+      let rec loop bindings' = match bindings' with
+          [] -> get_var_from_context ((st, cxt'), env, prefix)
+        | {pvb_pat = p; pvb_expr = e} :: rest ->
+            if pat_appears st p then
+              if flg = Recursive
+              then (* 定義された全ての変数が見えている *)
+                let cxt'' = List.fold_right
+                              (fun {pvb_pat = pat} c -> Lambda (pat, c))
+                              bindings cxt in
+                [((e, cxt''), env, prefix)]
+              else [((e, cxt'), env, prefix)]
+            else loop rest
+      in loop bindings
+
+(* structure_to_prefix : structure -> Env.t -> str_context ->
+                         Env.t * str_context *)
+let rec structure_to_prefix structure env prefix = match structure with
+    [] -> (env, prefix)
+  | s :: rest ->
+      let (_, _, env') = Typemod.type_structure env [s] Location.none in
+      structure_to_prefix rest env' ((s, env) :: prefix)
+
+(* get_module_from_prefix : string -> Env.t -> str_context ->
+                            (Env.t * str_context) option *)
+let rec get_module_from_prefix st env prefix = match prefix with
+    [] -> None (* This happens when no binding is found, such as for 'List' *)
+  | ({ pstr_desc = Pstr_module ({pmb_name = {txt = st'};
+                                 pmb_expr = {pmod_desc = Pmod_structure
+                                                           (structure)}}) },
+     env) :: rest ->
+      (* module A = struct ... end 文のみ考慮 *)
+      if st = st'
+      then Some (structure_to_prefix structure env prefix)
+      else get_module_from_prefix st env rest
+  | _ :: rest -> (* 他は無視。しかし recmodule は必要っぽい *)
+      get_module_from_prefix st env rest
+
+(* get_module : Longident.t context_t -> (Env.t * str_context) option *)
+let rec get_module ((longident, cxt), env, prefix) = match longident with
+    Longident.Lident (st) ->
+      get_module_from_prefix st env prefix
+  | Longident.Ldot (longident, st) ->
+      begin match get_module ((longident, cxt), env, prefix) with
+          None -> None
+        | Some (env', prefix') -> get_module_from_prefix st env' prefix'
+      end
+  | Longident.Lapply (_, _) ->
+      failwith "TypeDebugger: Longident.Lapply in get_module"
+
+(* get : Longident.t context_t -> expression context_t list *)
+let get ((longident, cxt), env, prefix) = match longident with
+    Longident.Lident (st) ->
+      get_var_from_context ((st, cxt), env, prefix)
+  | Longident.Ldot (longident, st) ->
+      begin match get_module ((longident, cxt), env, prefix) with
+          None -> []
+        | Some (_, prefix') -> get_var_from_prefix st prefix'
+      end
+  | Longident.Lapply (_, _) ->
+      failwith "TypeDebugger: Longident.Lapply in get"
+
+(********** pattern **********)
+
+(* wrap_exp : expression_desc -> pattern -> expression *)
+let wrap_exp desc {ppat_desc = _; ppat_loc = l; ppat_attributes = a} =
+  {pexp_desc = desc; pexp_loc = l; pexp_attributes = a}
+
+(* pat_to_exp : pattern -> expression *)
+let rec pat_to_exp pat = match pat.ppat_desc with
+  | Ppat_any ->
+      (* _ *)
+      skeleton
+  | Ppat_var ({txt = st; loc = loc'}) ->
+      (* Ppat_var of string loc *)
+      (* x *)
+      wrap_exp (Pexp_ident ({txt = Longident.Lident(st); loc = loc'})) pat
+  | Ppat_constant (c) ->
+      (* 1, 'a', "true", 1.0, 1l, 1L, 1n *)
+      wrap_exp (Pexp_constant (c)) pat
+  | Ppat_tuple (ps) ->
+      (* Ppat_tuple of pattern list *)
+      (* (P1, ..., Pn) Invariant: n >= 2 *)
+      wrap_exp (Pexp_tuple (List.map pat_to_exp ps)) pat
+  | Ppat_construct (lid, p) ->
+      (* Ppat_construct of Longident.t loc * pattern option *)
+      (* C                None
+         C P              Some P
+         C (P1, ..., Pn)  Some (Ppat_tuple [P1; ...; Pn]) *)
+      wrap_exp (Pexp_construct (lid, match p with
+                                         None -> None
+                                       | Some p' -> Some (pat_to_exp p')))
+               pat
+  | Ppat_record (lps, _) ->
+      (* Ppat_record of (Longident.t loc * pattern) list * closed_flag *)
+      (* { l1=P1; ...; ln=Pn }     (flag = Closed)
+         { l1=P1; ...; ln=Pn; _}   (flag = Open)
+         Invariant: n > 0 *)
+      (* パターンにフィールドが全部、書かれていないとエラーになる *)
+      (* 要対処 *)
+      wrap_exp (Pexp_record (List.map (fun (l, p) -> (l, pat_to_exp p)) lps,
+                             None))
+               pat
+  | Ppat_constraint (p, ct) ->
+      (* (P : T) *)
+      wrap_exp (Pexp_constraint (pat_to_exp p, ct)) pat
+  | _ -> skeleton
+
+(* wrap_pat : pattern_desc -> pattern -> pattern *)
+let wrap_pat desc {ppat_desc = _; ppat_loc = l; ppat_attributes = a} =
+  {ppat_desc = desc; ppat_loc = l; ppat_attributes = a}
+
+(* cons_unconstrained_pat : pattern -> expr_context -> expr_context *)
+(* pat を（型制約のない）変数の列のパターンに変換して cxt の上に積む *)
+let cons_unconstrained_pat pat cxt = match pattern_variables pat with
+  | [] -> cxt
+  | first :: [] ->
+      Lambda (wrap_pat (Ppat_var ({txt = first; loc = Location.none})) pat,
+              cxt)
+  | lst ->
+      let lst' = List.map (fun s -> wrap_pat (Ppat_var ({txt = s;
+                                                         loc = Location.none}))
+                                             pat)
+                          lst in
+      Lambda (wrap_pat (Ppat_tuple lst') pat, cxt)
+
+(* extract_pattern : expression -> pattern list *)
+let extract_pattern exp = match exp.pexp_desc with
+    Parsetree.Pexp_let (_, bindings, _) ->
+      List.map (fun {pvb_pat = pat} -> pat) bindings
+  | Parsetree.Pexp_function (cases) ->
+      List.map (fun {pc_lhs = pat} -> pat) cases
+  | Parsetree.Pexp_fun (_, _, pat, _) -> [pat]
+  | Parsetree.Pexp_match (_, cases) ->
+      List.map (fun {pc_lhs = pat} -> pat) cases
+  | Parsetree.Pexp_try (_, cases) ->
+      List.map (fun {pc_lhs = pat} -> pat) cases
+(*| Parsetree.Pexp_for (_, exp1, exp2, _, exp3) -> [] *)
+(*| Parsetree.Pexp_letmodule (_, _, exp) -> [] *)
+  | _ -> []
+
+(* decompose_pattern : pattern -> pattern list *)
+let decompose_pattern pat = match pat.ppat_desc with
+    Ppat_any -> []
+  | Ppat_var (_) -> []
+  | Ppat_alias (p, _) -> [p]
+  | Ppat_constant (_) -> []
+  | Ppat_interval (_, _) -> []
+  | Ppat_tuple (ps) -> ps
+  | Ppat_construct (_, None) -> []
+  | Ppat_construct (_, Some (p)) -> [p]
+  | Ppat_variant (_, None) -> []
+  | Ppat_variant (_, Some (p)) -> [p]
+  | Ppat_record (lps, _) -> List.map (fun (_, p) -> p) lps
+  | Ppat_array (ps) -> ps
+  | Ppat_or (p1, p2) -> [p1; p2]
+  | Ppat_constraint (p, _) -> [p]
+  | Ppat_type (_) -> []
+  | Ppat_lazy (p) -> [p]
+  | Ppat_unpack (_) -> []
+  | Ppat_exception (p) -> [p]
+  | Ppat_extension (_) -> []
+  | Ppat_open (_, p) -> [p]
+
+(********** decompose **********)
+
+(* two phases of decompose *)
+type decompose_phase_t =
+    Illtyped (* decompose する式には型がつかない *)
+  | Typed    (* decompose する式に型はついている *)
+
+(* decompose_case : case context_t -> expression context_t list *)
+let decompose_case ((case, cxt), env, prefix) = match case with
+  | {pc_lhs = pat; pc_guard = None; pc_rhs = exp} ->
+      let cxt' = cons_unconstrained_pat pat cxt in
+      [((exp, cxt'), env, prefix); ((pat_to_exp pat, cxt'), env, prefix)]
+  | {pc_lhs = pat; pc_guard = Some (g); pc_rhs = exp} ->
+      let cxt' = cons_unconstrained_pat pat cxt in
+      [((g, cxt), env, prefix);
+       ((pat_to_exp pat, cxt'), env, prefix);
+       ((exp, cxt'), env, prefix)]
+
+(* decompose_expr : expression context_t -> decompose_phase_t ->
+                    expression context_t list *)
+let decompose_expr ((exp, cxt), env, prefix) phase =
+  match exp.pexp_desc with
+     Parsetree.Pexp_ident ({txt = longident}) ->
+       begin match phase with
+           Illtyped -> []
+         | Typed -> get ((longident, cxt), env, prefix)
+       end
+   | Parsetree.Pexp_constant (_) -> []
+   | Parsetree.Pexp_let (rec_flg, bindings, exp) ->
+       (* let 文で定義された変数を含めたコンテキストを cxt' とする *)
+       let cxt' = List.fold_right (fun {pvb_pat = pat} c ->
+                                    cons_unconstrained_pat pat c)
+                                  bindings cxt in
+       begin match phase with
+(* ------------------------------------------------------------------------ *)
+(*
+  Illtyped ->
+    if rec_flg = Recursive
+    (* let rec ではパターンは書けないためパターンについては考慮不要 *)
+    then let bindings' = List.map (fun binding ->
+                                    {binding with pvb_expr = skeleton})
+                                  bindings in
+         List.fold_right
+           (fun {pvb_expr = exp} lst -> ((exp, cxt'), env, prefix) :: lst)
+           bindings [((exp, Let (rec_flg, bindings', cxt)), env, prefix)]
+(*       List.map (fun {pvb_expr = exp} -> ((exp, cxt'), env, prefix)) bindings
+         @ [((exp, Let (rec_flg, bindings', cxt)), env, prefix)] *)
+    (* let ではパターンを考慮 *)
+    (* （まだ考慮できていない） *)
+    else List.fold_right
+           (fun {pvb_pat = pat; pvb_expr = exp} lst ->
+             ((pat_to_exp pat, cxt), env, prefix) ::
+             ((exp, cxt), env, prefix) :: lst)
+           bindings [((exp, cxt'), env, prefix)]
+(*       List.map (fun {pvb_expr = exp} -> ((exp, cxt), env, prefix)) bindings
+         @ [((exp, cxt'), env, prefix)] *)
+| Typed -> [((exp, Let (rec_flg, bindings, cxt)), env, prefix)] (* cxt'? *)
+         (* exp 中から束縛された値が見える *)
+ *)
+(* ------------------------------------------------------------------------ *)
+  Illtyped ->
+    (* let 文で定義された変数を含めたコンテキストを cxt' とする *)
+(*    let cxt' = List.fold_right (fun {pvb_pat = pat} c -> Lambda (pat, c))
+                               bindings cxt in *)
+    if rec_flg = Recursive
+    then let bindings' = List.map (fun binding ->
+                                    {binding with pvb_expr = dummy_fun})
+                                  bindings in
+         List.map (fun {pvb_expr = exp} -> ((exp, cxt'), env, prefix)) bindings
+         @ [((exp, Let (rec_flg, bindings', cxt)), env, prefix)]
+    else let bindings' = List.map (fun binding ->
+                                    {binding with pvb_expr = skeleton})
+                                  bindings in
+         List.map (fun {pvb_expr = exp} -> ((exp, cxt), env, prefix)) bindings
+         @ [((exp, Let (rec_flg, bindings', cxt)), env, prefix)]
+(*
+| Typed_fv ->
+       (* let 文で定義された変数を含めたコンテキストを cxt' とする *)
+       let cxt' = List.fold_right (fun (pat, _) c -> expand_lambda pat c)
+                                  bindings cxt in
+       (if rec_flg = Recursive
+        then List.map (fun (_, exp) -> ((exp, cxt'), env, prefix)) bindings
+             (* 再帰関数なら、cxt' を使う *)
+        else List.map (fun (_, exp) -> ((exp, cxt), env, prefix)) bindings)
+       @ [((exp, Let (rec_flg, bindings, cxt)), env, prefix)]
+         (* exp 中から束縛された値が見える *)
+*)
+| Typed -> [((exp, Let (rec_flg, bindings, cxt)), env, prefix)]
+         (* exp 中から束縛された値が見える *)
+(* ------------------------------------------------------------------------ *)
+       end
+   | Parsetree.Pexp_function (cases) ->
+       List.flatten (List.map
+                      (fun case -> decompose_case ((case, cxt), env, prefix))
+                      cases)
+   | Parsetree.Pexp_fun (_, None, pat, exp) ->
+       let cxt' = cons_unconstrained_pat pat cxt in
+       let exp' = pat_to_exp pat in
+        ((exp', cxt'), env, prefix) :: [((exp, cxt'), env, prefix)]
+   | Parsetree.Pexp_fun (_, Some (exp1), pat, exp) ->
+      let cxt' = cons_unconstrained_pat pat cxt in
+      ((exp1, cxt), env, prefix) :: (
+        (pat_to_exp pat, cxt'), env, prefix) :: [((exp, cxt'), env, prefix)]
+   | Parsetree.Pexp_apply (exp, lexps) ->
+       ((exp, cxt), env, prefix) ::
+       List.map (fun (_, exp) -> ((exp, cxt), env, prefix)) lexps
+   | Parsetree.Pexp_match (exp, cases) ->
+       ((exp, cxt), env, prefix) ::
+       List.flatten (List.map
+                      (fun case -> decompose_case ((case, cxt), env, prefix))
+                      cases)
+   | Parsetree.Pexp_try (exp, cases) ->
+       ((exp, cxt), env, prefix) ::
+       List.flatten (List.map
+                      (fun case -> decompose_case ((case, cxt), env, prefix))
+                      cases)
+   | Parsetree.Pexp_tuple (exps) ->
+       List.map (fun exp -> ((exp, cxt), env, prefix)) exps
+   | Parsetree.Pexp_construct (_, None) -> []
+   | Parsetree.Pexp_construct (_, Some ({pexp_desc = Pexp_tuple (exps)})) ->
+       (* :: など infix の構成子だと組をハイライトできないため *)
+       List.map (fun exp -> ((exp, cxt), env, prefix)) exps
+   | Parsetree.Pexp_construct (_, Some (exp)) ->
+       [((exp, cxt), env, prefix)]
+   | Parsetree.Pexp_variant (_, None) -> []
+   | Parsetree.Pexp_variant (_, Some (exp)) ->
+       [((exp, cxt), env, prefix)]
+   | Parsetree.Pexp_record (lexps, None) ->
+       List.map (fun (_, exp) -> ((exp, cxt), env, prefix)) lexps
+   | Parsetree.Pexp_record (lexps, Some (exp)) ->
+       ((exp, cxt), env, prefix) ::
+       List.map (fun (_, exp) -> ((exp, cxt), env, prefix)) lexps
+   | Parsetree.Pexp_field (exp, _) ->
+       [((exp, cxt), env, prefix)]
+   | Parsetree.Pexp_setfield (exp1, _, exp2) ->
+       [((exp1, cxt), env, prefix); ((exp2, cxt), env, prefix)]
+   | Parsetree.Pexp_array (exps) ->
+       List.map (fun exp -> ((exp, cxt), env, prefix)) exps
+   | Parsetree.Pexp_ifthenelse (exp1, exp2, None) ->
+       [((exp1, cxt), env, prefix); ((exp2, cxt), env, prefix)]
+   | Parsetree.Pexp_ifthenelse (exp1, exp2, Some (exp3)) ->
+       [((exp1, cxt), env, prefix); ((exp2, cxt), env, prefix);
+        ((exp3, cxt), env, prefix)]
+   | Parsetree.Pexp_sequence (exp1, exp2) ->
+       [((exp1, cxt), env, prefix); ((exp2, cxt), env, prefix)]
+   | Parsetree.Pexp_while (exp1, exp2) ->
+       [((exp1, cxt), env, prefix); ((exp2, cxt), env, prefix)]
+   | Parsetree.Pexp_constraint (exp, _)
+       when exp = hole_of_exp exp ->
+       []
+   | Parsetree.Pexp_constraint (exp1, typ) ->
+       let exp' = { exp with
+                    pexp_desc = Pexp_constraint (hole_of_exp exp, typ) }
+       in [((exp', cxt), env, prefix);
+           ((exp1, cxt), env, prefix)]
+   | Parsetree.Pexp_send (exp, _) ->
+       [((exp, cxt), env, prefix)]
+   | Parsetree.Pexp_setinstvar (_, exp) ->
+       [((exp, cxt), env, prefix)]
+   | Parsetree.Pexp_assert (exp) ->
+       [((exp, cxt), env, prefix)]
+   | Parsetree.Pexp_lazy (exp) ->
+       [((exp, cxt), env, prefix)]
+   | Parsetree.Pexp_open (_, _, exp) ->
+       [((exp, cxt), env, prefix)]
+   | _ ->
+       Format.fprintf ppf
+         "default case of decompose:@ %a@." Pprintast.expression exp;
+       []
+
+(********** obtain type and environment of expr **********)
+
+(* type of elements of yes/no list *)
+(* type yes_no_list = (string context_t * type_expr) list *)
+(* yes_no_list という名前を使っているが、ここでは環境として使っている *)
+
+(* collect_one : (string context_t * type_expr) list context_t -> string list ->
+                 type_expr -> yes_no_list * type_expr *)
+let collect_one ((vartyps, cxt'), env, prefix) vars typ =
+  match decode_tuple typ with
+      Some (exp_typ :: _ :: typs) -> (* _ は dummy_int0 の型 *)
+        (List.map2 (fun v t -> (((v, cxt'), env, prefix), t)) vars typs
+         @ vartyps,
+         exp_typ)
+    | Some ([_]) | Some ([]) | None ->
+        Format.fprintf ppf "type:@.%a@." Printtyp.type_expr typ;
+        failwith "TypeDebugger: Error in collect_one"
+
+(* collect : expression context_t -> type_expr -> yes_no_list * type_expr *)
+let rec collect ((expr, cxt), env, prefix) t = match cxt with
+    Empty -> ([], t)
+  | Lambda (pat, cxt') ->
+      (* There and back again [Danvy&Goldberg ICFP'02] *)
+      let (vartyps, t') = collect ((expr, cxt'), env, prefix) t in
+      let vars = pattern_variables pat in
+      begin match split_arrow t' with
+          Some (_, t2) ->
+            collect_one ((vartyps, cxt'), env, prefix) vars t2
+        | None -> (* Can't happen *)
+            failwith "TypeDebugger: Error in collect"
+      end
+  | Let (_, _, cxt') -> collect ((expr, cxt'), env, prefix) t
+
+(* judge : expression context_t -> yes_no_list * type_expr *)
+let judge ((expr, cxt), env, prefix) =
+  let structure = plug_str (expr, cxt) in
+  let (structure', _, _) = Typemod.type_structure env structure Location.none in
+  match structure'.str_items with
+    {str_desc = Tstr_eval ({ exp_type = typ }, _)} :: [] ->
+      collect ((expr, cxt), env, prefix) typ
+  | _ -> failwith "TypeDebugger: Error in judge"
+
+(********** check whether the question was already answered **********)
+
+(* trace_answer : bool *)
+(* change this variable to true to show the answer trace *)
+let trace_answer = false
+
+(* answered_yes : string context_t -> type_expr -> yes_no_list -> Env.t ->
+                  bool *)
+let answered_yes (((st, _), _, _) as key) typ yes env = try
+  let t = List.assoc key yes in
+  let b = Ctype.moregeneral env false typ t in
+  if trace_answer then Format.fprintf ppf "answered_yes %s = %b@\n" st b;
+  b
+with Not_found -> false
+
+(* answered_no : string context_t -> type_expr -> yes_no_list -> Env.t ->
+                 bool *)
+let answered_no (((st, _), _, _) as key) typ no env = try
+  let t = List.assoc key no in
+  let b = Ctype.moregeneral env false t typ in
+  if trace_answer then Format.fprintf ppf "answered_no %s = %b@\n" st b;
+  b
+with Not_found -> false
+
+(********** the source of the type error identified; make messages **********)
+
+(* iter4 : ('a -> 'b -> 'c -> 'd -> unit) ->
+           'a list -> 'b list -> 'c list -> 'd list -> unit *)
+let rec iter4 f lst1 lst2 lst3 lst4 = match (lst1, lst2, lst3, lst4) with
+    ([], [], [], []) -> ()
+  | (f1 :: r1, f2 :: r2, f3 :: r3, f4 :: r4) ->
+      f f1 f2 f3 f4;
+      iter4 f r1 r2 r3 r4
+  | (_, _, _, _) ->
+      failwith "TypeDebugger: Error in iter4"
+
+(* make_message_pattern : pattern context_t -> unit *)
+let make_message_pattern ((pat, _), _, _) =
+  print_loc pat.ppat_loc;
+  print_identified ();
+  print_pattern ()
+
+(* make_message_recursive1 : value_binding context_t -> unit *)
+(* 長さが１の場合を特別扱い（長さ 1 の tuple が許されないため） *)
+let make_message_recursive1 ((binding, cxt), env, prefix) =
+  (* パターンを集めてくる *)
+  let pat = binding.pvb_pat in
+  (* その中の変数 *)
+  let vars = pattern_variables pat in
+  begin match vars with
+      [] -> (* Can't happen *)
+        failwith "TypeDebugger: Error in make_message_recursive1a"
+    | [var] ->
+        (* 変数名から変数の expression を作る関数 *)
+        let varexp x = Exp.mk (Pexp_ident (mknoloc (Longident.Lident x))) in
+        (* body を定義される変数にした再帰しない let 文 *)
+        let exp1 = Exp.mk (Pexp_let (Nonrecursive, [binding], varexp var)) in
+        (* それを単相の vars 用の fun 文で囲む *)
+        (* bindings = let rec f = e in ... なら *)
+        (* exp2 = fun f -> let f = e in f *)
+        (* fun f が used_typ を与え in f が inferred_typ を与える *)
+        let exp2 = Exp.mk (Pexp_fun (Nolabel, None, pat, exp1)) in
+        if debug land 4 = 4 then Format.fprintf ppf "exp2:@.%a@."
+                                   Pprintast.expression exp2;
+        (* その型を求める *)
+        let (_, typ) = judge ((exp2, cxt), env, prefix) in
+        begin match split_arrow typ with
+            None -> (* Can't happen *)
+              failwith "TypeDebugger: Error in make_message_recursive1b"
+          | Some (used_typ, inferred_typ) ->
+              print_loc binding.pvb_expr.pexp_loc;
+              print_identified ();
+              print_recursive inferred_typ var used_typ
+              (*
+              以下の場合分けは不要。then のケースは occur check に
+              引っかかったことを示す。let rec f x = f とか。
+              if Ctype.moregeneral env false used_typ inferred_typ
+              then print_recursive inferred_typ var used_typ
+              else print_recursive inferred_typ var used_typ
+              *)
+        end
+    | _ :: _ -> (* let rec で定義されるものが変数ではなくパターン *)
+        failwith "TypeDebugger: non-variable let rec not supported1."
+  end
+
+(* make_message_recursive_many : value_binding list context_t -> unit *)
+let make_message_recursive_many ((bindings, cxt), env, prefix) =
+  (* パターンを集めてくる *)
+  let pats = List.map (fun {pvb_pat = pat} -> pat) bindings in
+  (* その中の変数たち *)
+  let varss = List.map pattern_variables pats in
+  if List.exists (fun vars -> List.length vars <> 1) varss
+  then (* let rec で定義されるものが変数ではなくパターン *)
+    failwith "TypeDebugger: non-variable let rec not supported."
+  else
+    (* 定義される変数全て *)
+    let vars = List.flatten varss in
+    (* 変数名から変数の expression を作る関数 *)
+    let varexp x = Exp.mk (Pexp_ident (mknoloc (Longident.Lident x))) in
+    (* body を定義される変数の組にした再帰しない let 文 *)
+    let body = Exp.mk (Pexp_tuple (List.map varexp vars)) in
+    let exp1 = Exp.mk (Pexp_let (Nonrecursive, bindings, body)) in
+    (* それを単相の vars 用の fun 文で囲む *)
+    (* bindings = let rec f1 = e1 and f2 = e2 in ... なら *)
+    (* exp2 = fun (f1, f2) -> let f1 = e1 and f2 = e2 in (f1, f2) *)
+    let pat2 = Pat.mk (Ppat_tuple pats) in
+    let exp2 = Exp.mk (Pexp_fun (Nolabel, None, pat2, exp1)) in
+    (* その型を求める *)
+    let (_, typ) = judge ((exp2, cxt), env, prefix) in
+    begin match split_arrow typ with
+        None -> (* Can't happen *)
+          failwith "TypeDebugger: Error in make_message_recursive_many"
+      | Some (used_typ, inferred_typ) ->
+          begin match (decode_tuple used_typ, decode_tuple inferred_typ) with
+              (Some (used_typs), Some (inferred_typs)) ->
+                print_identified ();
+                iter4 (fun utyp ityp var binding ->
+                         if Ctype.moregeneral env false utyp ityp
+                         then ()
+                         else begin
+                           print_loc binding.pvb_expr.pexp_loc;
+                           print_recursive ityp var utyp
+                         end)
+                      used_typs inferred_typs vars bindings
+            | (_, _) ->
+                failwith "TypeDebugger: Error in make_message_recursive_many2"
+          end
+    end
+
+(* make_message_recursive : value_binding list context_t -> unit *)
+(* recursive なパターン pats = exps が型エラーの原因 *)
+(* 関数の定義と再帰呼び出し時の型がずれている *)
+let make_message_recursive ((bindings, cxt), env, prefix) = match bindings with
+    [] -> (* Can't happen *)
+      failwith "TypeDebugger: Error in make_message_recursive"
+  | [binding] ->
+      make_message_recursive1 ((binding, cxt), env, prefix)
+  | _ :: _ ->
+      make_message_recursive_many ((bindings, cxt), env, prefix)
+
+(* make_message_bindings : value_binding list context_t -> unit *)
+(* パターン pats = exps が型エラーの原因 *)
+(* binding は recursive ではない *)
+let make_message_bindings ((bindings, cxt), env, prefix) =
+  let rec loop bindings = match bindings with
+      [] -> failwith "TypeDebugger: Error in make_message_bindings"
+    | {pvb_pat = pat; pvb_expr = exp} as binding :: rest ->
+        let exp0 = { pexp_desc       = Pexp_let (Nonrecursive, [binding],
+                                                skeleton);
+                     pexp_loc        = Location.none;
+                     pexp_attributes = [] } in
+        if is_well_typed_expr ((exp0, cxt), env, prefix)
+        then loop rest
+        else begin match pat with
+            { ppat_desc = Ppat_constant (_) } -> (* constant のとき *)
+              print_loc pat.ppat_loc;
+              print_identified ();
+              print_patexps2 ()
+          | _ -> (* それ以外のパターン *)
+              let (_, typ) = judge ((exp, cxt), env, prefix) in
+              print_loc exp.pexp_loc;
+              print_identified ();
+              print_patexps typ
+        end
+  in loop bindings
+
+(* とりあえず型チェック *)
+let make_message_case ((case, cxt), env, prefix) =
+  (* case の式を歩く関数 *)
+  let rec walk_in_case exp progs = match progs with
+    | [] ->
+       let (lhs, rhs) = (case.pc_lhs, case.pc_rhs) in
+       if exp = skeleton then
+         let progs' =
+           decompose_expr ((case.pc_rhs, cxt), env, prefix) Illtyped in
+         walk_in_case skeleton progs'
+       else
+         (* 変数を特定 *)
+         let loc =
+           let (lloc, rloc) = (lhs.ppat_loc, rhs.pexp_loc) in
+           {loc_start = lloc.loc_start;
+            loc_end = rloc.loc_end;
+            loc_ghost = rloc.loc_ghost;} in
+         (lhs, loc, exp)
+    | ((expr', _), env', _) :: rest ->
+       try
+         ignore(Typecore.type_expression env' expr');
+         walk_in_case exp rest
+       with
+       | _ ->
+          (* expr' がエラーになる式だった *)
+          let rest' =
+            decompose_expr ((expr', cxt), env, prefix) Illtyped in
+          walk_in_case expr' rest' in
+  (* 実行結果 *)
+  let (_, loc, exp) = walk_in_case skeleton [] in
+  print_loc loc;
+  print_identified ();
+  print_illtyped_case exp
+
+(* bool_typ : core_type *)
+let bool_typ = Typ.mk (Ptyp_constr (mknoloc (Longident.Lident "bool"), []))
+                          
+(* unit_typ : core_type *)
+let unit_typ = Typ.mk (Ptyp_constr (mknoloc (Longident.Lident "unit"), []))
+
+(* is_bool_expr : expression context_t -> bool *)
+let is_bool_expr ((exp, cxt), env, prefix) =
+  (* exp with bool annotation *)
+  let exp' = { exp with pexp_desc = Pexp_constraint (exp, bool_typ) } in
+  is_well_typed_expr ((exp', cxt), env, prefix)
+
+(* is_unit_expr : expression context_t -> bool *)
+let is_unit_expr ((exp, cxt), env, prefix) =
+  (* exp with unit annotation *)
+  let exp' = { exp with pexp_desc = Pexp_constraint (exp, unit_typ) } in
+  is_well_typed_expr ((exp', cxt), env, prefix)
+(*
+(* make_message_illtyped : expression context_t -> unit *)
+let make_message_illtyped ((expr, cxt), env, prefix) (* yes no *) =
+  match expr.pexp_desc with
+    Parsetree.Pexp_ident (_) ->
+      print_loc expr.pexp_loc;
+      print_identified ();
+      print_illtyped_var_undefined ()
+  | Parsetree.Pexp_ifthenelse (exp1, exp2, None) ->
+      if not (is_bool_expr ((exp1, cxt), env, prefix)) then
+        (* predicate 部分が bool 型でない *)
+        let (_, typ1) = judge ((exp1, cxt), env, prefix) in begin
+          print_loc exp1.pexp_loc;
+          print_identified ();
+          print_illtyped_if_predicate typ1
+        end
+      else if not (is_unit_expr ((exp2, cxt), env, prefix)) then
+        (* then 部分が unit 型でない *)
+        let (_, typ2) = judge ((exp2, cxt), env, prefix) in begin
+          print_loc exp2.pexp_loc;
+          print_identified ();
+          print_illtyped_if_then typ2
+        end
+      else begin (* both are well_typed; conflicts in environment *)
+        print_loc expr.pexp_loc;
+        print_identified ();
+        print_illtyped_if_fv ()
+      end
+
+  | Parsetree.Pexp_ifthenelse (exp1, exp2, Some (exp3)) ->
+      if not (is_bool_expr ((exp1, cxt), env, prefix)) then
+        (* predicate 部分が bool 型でない *)
+        let (_, typ1) = judge ((exp1, cxt), env, prefix) in begin
+          print_loc exp1.pexp_loc;
+          print_identified ();
+          print_illtyped_if_predicate typ1
+        end
+      else (* [exp2; exp3] を同じリストに入れる *)
+        let mtloc = mknoloc (Longident.Lident "[]") in
+        let mt = Exp.mk (Pexp_construct (mtloc, None)) in
+        let consloc = mknoloc (Longident.Lident "::") in
+        let cons e1 e2 =
+          let e = Exp.mk (Pexp_tuple [e1; e2]) in
+          Exp.mk (Pexp_construct (consloc, Some e)) in
+        let exp' = cons exp2 (cons exp3 mt) in
+        if not (is_well_typed_expr ((exp', cxt), env, prefix)) then
+          (* then 部分と else 部分が同じ型でない *)
+          (* または then 部分と else 部分で環境の衝突が起きた *)
+          let (_, typ2) = judge ((exp2, cxt), env, prefix) in
+          let (_, typ3) = judge ((exp3, cxt), env, prefix) in begin
+            print_loc expr.pexp_loc;
+            print_identified ();
+            print_illtyped_if_then_else typ2 typ3
+          end
+        else begin (* if 文全体で環境の衝突が起きている *)
+          print_loc expr.pexp_loc;
+          print_identified ();
+          print_illtyped_if_fv ()
+        end
+
+  | Parsetree.Pexp_apply (exp, lexps) ->
+      let (_, exp_typ) = judge ((exp, cxt), env, prefix) in (* 関数の型 *)
+      let typs = List.map (fun (_, e) -> snd (judge ((e, cxt), env, prefix)))
+                          lexps in (* 引数の型 *)
+      let exps = List.map (fun (_, e) -> e) lexps in
+      if split_arrow exp_typ = None then begin
+        (* 関数部分が関数型になっていない *)
+        print_loc expr.pexp_loc;
+        print_identified ();
+        print_illtyped_apply_not_function exp_typ
+      end else
+        (* 型エラーを起こすことなく渡せる引数列と
+         * 型エラーを起こす最初の引数のペアを返す *)
+        let rec well_typed_args wargs lexps = match lexps with
+            [] ->
+              failwith "TypeDebugger: Error: apply in make_message_illtyped."
+          | first :: rest ->
+              let wargs' = wargs @ [first] in
+              let exp' = Exp.mk (Pexp_apply (exp, wargs')) in
+              if is_well_typed_expr ((exp', cxt), env, prefix)
+              then well_typed_args wargs' rest
+              else (wargs, first) in
+        let (wargs, (_, arg)) = well_typed_args [] lexps in
+        (* 何番目の引数が型エラーを引き起こすか *)
+        let n = List.length wargs + 1 in
+        (* 型エラーになる直前までの型 *)
+        let typ = if n = 1 then exp_typ
+                  else let wexp = Exp.mk (Pexp_apply (exp, wargs)) in
+                       snd (judge ((wexp, cxt), env, prefix)) in
+                       (* wargs = [] だと judge が syntax error を起こす *)
+        begin match split_arrow typ with
+            None -> (* typ が関数型でなかった：引数が多かった場合 *)
+              print_loc expr.pexp_loc;
+              print_identified ();
+              print_illtyped_too_much_args n exp_typ typs exp
+          | Some (t1, _) -> (* n 番目の引数が型エラー *)
+              print_loc expr.pexp_loc;
+              print_identified ();
+              if language_level < 2
+              then (* language_level < 2 では関数引数は不可 *)
+                let (_, n_typ) = judge ((arg, cxt), env, prefix) in
+                (* 型エラーの原因となっている引数の型 *)
+                let funtypes = find_funtype_args typs 1 in
+                (* 関数型になっている引数 *)
+                begin match funtypes with
+                    [] -> (* 関数型になっている引数なし *)
+                      print_illtyped_apply_beginning2 n exp exp_typ n_typ
+                  | _ -> (* 関数型になっている引数あり *)
+                      print_illtyped_apply_beginning n exp exp_typ typs funtypes
+                end
+              (* language_level >= 2 は関数引数可 *)
+              else
+                print_illtyped_apply_funname n exp_typ exps typs t1 exp
+        end
+
+  | Parsetree.Pexp_function (_) ->
+      print_illtyped_function ()
+
+  | Parsetree.Pexp_fun (_, _, _, _) ->
+      print_illtyped_function ()
+
+  | Parsetree.Pexp_match (exp, cases) ->
+  (* Pexp_match の補助変数 ------------------------------------------------ *)
+      (* body と guard を無効にした cases *)
+      let pattern_only_cases =
+        List.map (fun {pc_lhs = pat; } ->
+                    {pc_lhs = pat; pc_guard = None; pc_rhs = skeleton})
+                 cases in
+      (* body のみを無効にした cases *)
+      let pattern_and_guard_cases =
+        List.map (fun {pc_lhs = pat; pc_guard = g; } ->
+                    {pc_lhs = pat; pc_guard = g; pc_rhs = skeleton})
+                 cases in
+
+  (* Pexp_match の補助関数 ------------------------------------------------ *)
+      (* pattern の型が合っているかを調べる *)
+      (* pattern をひとつずつ加えて、型がつかなくなるところを探す *)
+      let rec patterns_ok exp wcases cases = match cases with
+          [] -> true (* すべての case を入れて型がついた *)
+        | case :: rest ->
+            let wcases' = wcases @ [case] in
+            let exp' = Exp.mk (Pexp_match (exp, wcases')) in
+            if is_well_typed_expr ((exp', cxt), env, prefix)
+            then patterns_ok exp wcases' rest
+            else begin match wcases with
+                [] -> (* 最初の case が型エラー。exp と case が合わない*)
+                  let case' = Exp.mk (Pexp_function ([case])) in
+                  if debug land 8 = 8 then
+                    Format.fprintf ppf "message illtyped match1:@.%a@."
+                      Pprintast.expression case';
+                  (* 最初のパターンの型 *)
+                  let (_, pat_typ) = judge ((case', cxt), env, prefix) in
+                  begin match split_arrow pat_typ with
+                    Some (t1, _) ->
+                      (* exp の型 *)
+                      let (_, exp_typ) = judge ((exp, cxt), env, prefix) in
+                      print_loc expr.pexp_loc;
+                      print_identified ();
+                      print_illtyped_match_exp exp_typ t1;
+                      false
+                  | None -> (* Can't happen *)
+                      failwith "TypeDebugger: match2 in make_message_illtyped."
+                  end
+              | _ :: _ -> (* case 同士で型エラー *)
+                  let wcases' = Exp.mk (Pexp_function (wcases)) in
+                  (* 型が合っている case の型 *)
+                  let (_, ok_typ) = judge ((wcases', cxt), env, prefix) in
+                  let case' = Exp.mk (Pexp_function ([case])) in
+                  if debug land 8 = 8 then
+                    Format.fprintf ppf "message illtyped match3:@.%a@."
+                      Pprintast.expression case';
+                  (* 型が合わない case の型 *)
+                  let (_, notok_typ) = judge ((case', cxt), env, prefix) in
+                  begin match (split_arrow ok_typ, split_arrow notok_typ) with
+                    (Some (ok1, _), Some (notok1, _)) ->
+                      print_loc case.pc_lhs.ppat_loc;
+                      print_identified ();
+                      print_illtyped_match_left notok1 ok1;
+                      false
+                  | (_, _) -> (* Can't happen *)
+                      failwith "TypeDebugger: match4 in make_message_illtyped."
+                  end
+            end in
+      (* guard が全て bool かどうかを調べる *)
+      let guards_all_bool cases =
+        List.for_all
+          (function {pc_guard = None} -> true
+            | {pc_guard = Some (g)} ->
+                if is_bool_expr ((g, cxt), env, prefix)
+                then true
+                else begin
+                  let (_, g_typ) = judge ((g, cxt), env, prefix) in
+                  print_loc g.pexp_loc;
+                  print_identified ();
+                  print_guard g_typ;
+                  false
+                end)
+          cases in
+      (* guard と exp で環境が衝突していないかを調べる *)
+      let rec guards_ok_with_exp exp wcases cases = match cases with
+          [] -> true (* すべての case を入れて型がついた *)
+        | case :: rest ->
+            let wcases' = wcases @ [case] in
+            let exp' = Exp.mk (Pexp_match (exp, wcases')) in
+            if is_well_typed_expr ((exp', cxt), env, prefix)
+            then guards_ok_with_exp exp wcases' rest
+            else (* case に入っている guard で環境の衝突 *)
+              begin match case with
+                {pc_guard = None} -> (* Can't happen *)
+                  failwith "TypeDebugger: match5 in make_message_illtyped."
+              | {pc_guard = Some (g)} ->
+                  print_loc g.pexp_loc;
+                  print_identified ();
+                  print_guard_env ();
+                  false
+              end in
+      (* cases に型がつくかを順に調べる *)
+      (* 各ケースの型を独立に求め、その型が皆同じかを調べたい *)
+      (* すると、以後は、環境の衝突のみを考えれば良くなる *)
+      let rec cases_ok exp wcases cases = match cases with
+          [] -> true (* すべての case を入れて型がついた *)
+        | case :: rest ->
+            let wcases' = wcases @ [case] in
+            let exp' = Exp.mk (Pexp_match (exp, wcases')) in
+            if is_well_typed_expr ((exp', cxt), env, prefix)
+            then cases_ok exp wcases' rest
+            else (* case に入っている guard で環境の衝突 *)
+              begin match wcases with
+              | [] -> (* case がひとつ目からだめ *)
+                 (* exp と case で環境が conflict している *)
+                 (* print_loc expr.pexp_loc; *)
+                 (* print_identified (); *)
+                 (* print_illtyped_other (); (* メッセージを変えるべき *) *)
+                 (* false *)
+                 let progs = decompose_expr ((case.pc_rhs, cxt), env, prefix) Typed in
+                 List.iter (fun ((exp, _), _, _) -> Pprintast.expression ppf exp) progs;
+                 let loc = (case.pc_rhs).pexp_loc in
+                 print_loc loc;
+                 print_identified ();
+                 print_illtyped_case_env case.pc_rhs;
+                 false
+              | _ :: _ -> (* case の右辺の式、あるいは環境の衝突が原因 *)
+                  let wcases' = Exp.mk (Pexp_match (exp, wcases)) in
+                  if debug land 8 = 8 then
+                    Format.fprintf ppf "message illtyped match6:@.%a@."
+                      Pprintast.expression wcases';
+                  (* 型が合っている case の型 *)
+                  let (_, ok_typ) = judge ((wcases', cxt), env, prefix) in
+                  let case' = Exp.mk (Pexp_match (exp, [case])) in
+                  if debug land 8 = 8 then
+                    Format.fprintf ppf "message illtyped match7:@.%a@."
+                      Pprintast.expression case';
+                  (* 型が合わない case の型 *)
+                  begin try
+                    let (_, notok_typ) = judge ((case', cxt), env, prefix) in
+                    print_loc case.pc_rhs.pexp_loc;
+                    print_identified ();
+                    print_illtyped_match_right notok_typ ok_typ;
+                    false
+                  with _ -> (* 型エラーが起きた。環境が衝突している *)
+                    print_loc case.pc_rhs.pexp_loc;
+                    print_identified ();
+                    print_illtyped_match_right2 ();
+                    false
+                  end
+              end in
+
+  (* Pexp_match のメイン -------------------------------------------------- *)
+      if patterns_ok exp [] pattern_only_cases
+      && guards_all_bool pattern_and_guard_cases
+      && guards_ok_with_exp exp [] pattern_and_guard_cases
+      && cases_ok exp [] cases
+      then failwith "TypeDebugger: match is welltyped in make_message_illtyped."
+      else () (* error already reported in one of the predicates *)
+(*
+      (* exp は単独では型はついている。match 文全体では型はつかない *)
+      if debug land 8 = 8 then
+        Format.fprintf ppf "message illtyped match1:@.%a@."
+          Pprintast.expression exp;
+*)
+
+  | Parsetree.Pexp_try (exp, cases) ->
+  (* Pexp_try の補助変数 ------------------------------------------------ *)
+      (* body と guard を無効にした cases *)
+      let pattern_only_cases =
+        List.map (fun {pc_lhs = pat} ->
+                    {pc_lhs = pat; pc_guard = None; pc_rhs = skeleton})
+                 cases in
+      (* body のみを無効にした cases *)
+      let pattern_and_guard_cases =
+        List.map (fun {pc_lhs = pat; pc_guard = g} ->
+                    {pc_lhs = pat; pc_guard = g; pc_rhs = skeleton})
+                 cases in
+
+  (* Pexp_try の補助関数 ------------------------------------------------ *)
+      (* pattern の型が合っているかを調べる *)
+      (* pattern をひとつずつ加えて、型がつかなくなるところを探す *)
+      let rec patterns_ok exp wcases cases = match cases with
+          [] -> true (* すべての case を入れて型がついた *)
+        | case :: rest ->
+            let wcases' = wcases @ [case] in
+            let exp' = Exp.mk (Pexp_try (skeleton, wcases')) in
+            if is_well_typed_expr ((exp', cxt), env, prefix)
+            then patterns_ok exp wcases' rest
+            else begin match wcases with
+                [] -> true
+              | _ :: _ -> (* case 同士で型エラー *)
+                  let wcases' = Exp.mk (Pexp_function (wcases)) in
+                  (* 型が合っている case の型 *)
+                  let (_, ok_typ) = judge ((wcases', cxt), env, prefix) in
+                  let case' = Exp.mk (Pexp_function ([case])) in
+                  if debug land 8 = 8 then
+                    Format.fprintf ppf "message illtyped match3:@.%a@."
+                      Pprintast.expression case';
+                  (* 型が合わない case の型 *)
+                  let (_, notok_typ) = judge ((case', cxt), env, prefix) in
+                  begin match (split_arrow ok_typ, split_arrow notok_typ) with
+                    (Some (_, _), Some (notok1, _)) ->
+                      print_loc case.pc_lhs.ppat_loc;
+                      print_identified ();
+                      print_illtyped_try_left notok1;
+                      false
+                  | (_, _) -> (* Can't happen *)
+                      failwith "TypeDebugger: match4 in make_message_illtyped."
+                  end
+            end in
+      (* guard が全て bool かどうかを調べる *)
+      let guards_all_bool cases =
+        List.for_all
+          (function {pc_guard = None} -> true
+            | {pc_guard = Some (g)} ->
+                if is_bool_expr ((g, cxt), env, prefix)
+                then true
+                else begin
+                  let (_, g_typ) = judge ((g, cxt), env, prefix) in
+                  print_loc g.pexp_loc;
+                  print_identified ();
+                  print_guard g_typ;
+                  false
+                end)
+          cases in
+      (* guard と exp で環境が衝突していないかを調べる *)
+      let rec guards_ok_with_exp exp wcases cases = match cases with
+          [] -> true (* すべての case を入れて型がついた *)
+        | case :: rest ->
+            let wcases' = wcases @ [case] in
+            let exp' = Exp.mk (Pexp_try (exp, wcases')) in
+            if is_well_typed_expr ((exp', cxt), env, prefix)
+            then guards_ok_with_exp exp wcases' rest
+            else (* case に入っている guard で環境の衝突 *)
+              begin match case with
+                {pc_guard = None} -> (* Can't happen *)
+                  failwith "TypeDebugger: match5 in make_message_illtyped."
+              | {pc_guard = Some (g)} ->
+                  print_loc g.pexp_loc;
+                  print_identified ();
+                  print_guard_env ();
+                  false
+              end in
+      (* cases に型がつくかを順に調べる *)
+      (* 各ケースの型を独立に求め、その型が皆同じかを調べたい *)
+      (* すると、以後は、環境の衝突のみを考えれば良くなる *)
+      let rec cases_ok exp wcases cases = match cases with
+          [] -> true (* すべての case を入れて型がついた *)
+        | case :: rest ->
+            let wcases' = wcases @ [case] in
+            let exp' = Exp.mk (Pexp_try (exp, wcases')) in
+            if is_well_typed_expr ((exp', cxt), env, prefix)
+            then cases_ok exp wcases' rest
+            else (* case に入っている guard で環境の衝突 *)
+              begin match wcases with
+                [] | [_] | _ -> (* case がひとつ目からだめ *)
+                let case' = Exp.mk (Pexp_function ([case])) in
+                if debug land 8 = 8 then
+                  Format.fprintf ppf "message illtyped match1:@.%a@."
+                                 Pprintast.expression case';
+                (* 最初のパターンの型 *)
+                let (_, pat_typ) = judge ((case', cxt), env, prefix) in
+                begin match split_arrow pat_typ with
+                    Some (_, t2) ->
+                      (* exp の型 *)
+                      let (_, exp_typ) = judge ((exp, cxt), env, prefix) in
+                      let case_loc = (case.pc_rhs).pexp_loc in
+                      print_loc case_loc;
+                      print_identified ();
+                      (* 環境の衝突かどうかを確認 *)
+                      (try
+                          (Ctype.unify env exp_typ t2;
+                           print_illtyped_try_env ();
+                           false)
+                        with
+                          _ -> print_illtyped_try_right exp_typ t2;
+                      (* try文の式と矢印の右側の型が合わない *)
+                      false)
+                  | None -> (* Can't happen *)
+                      failwith "TypeDebugger: match2 in make_message_illtyped."
+                end
+              end in
+
+  (* Pexp_try のメイン -------------------------------------------------- *)
+      let exn_case =
+        [{ pc_lhs = { ppat_desc = Ppat_construct
+                                    ({txt = Longident.Lident ("Not_found");
+                                      loc = Location.none},
+                                     None);
+                      ppat_loc = Location.none;
+                      ppat_attributes = [] };
+           pc_guard = None;
+           pc_rhs = skeleton }] in
+      if (patterns_ok exp exn_case pattern_only_cases)
+      && (guards_all_bool pattern_and_guard_cases)
+      && (guards_ok_with_exp exp [] pattern_and_guard_cases)
+      && (cases_ok exp [] cases)
+      then failwith "TypeDebugger: match is welltyped in make_message_illtyped."
+      else () (* error already reported in one of the predicates *)
+
+  | Parsetree.Pexp_construct ({txt = lid}, e) ->
+      (* 引数の情報 *)
+      let args =
+        List.map (fun (e, t) ->
+                   if e = dummy_assertfalse e then None else Some (e, t))
+          (match e with
+            | Some (exp) ->
+               let typ = snd (judge ((exp, cxt), env, prefix)) in
+               begin
+                 (* 引数の数をチェック *)
+                 match (decode_tuple typ) with
+                 | Some (typs) ->
+                    let exps = match exp.pexp_desc with
+                      | Pexp_tuple (es) -> es
+                      | _ -> assert false in
+                    List.combine exps typs
+                 | None -> [(exp, typ)]
+               end
+            | None -> []) in
+
+      (* extract core type list from constructor arguments *)
+      (* extract_core_types : constructor_arguments -> core_type list *)
+      let extract_core_types carg = match carg with
+        | Pcstr_tuple (cts) -> cts
+        | Pcstr_record (_) -> assert false (* not supported yet *)
+      in
+
+      (* prefix の分解 *)
+      (* prefix -> (string * kind) list *)
+      let rec get_construct prefix = match prefix with
+        | [] -> []
+        | (first, _) :: rest ->
+            begin match first.pstr_desc with
+            | Pstr_type (_, tds) ->
+                (* 型の情報 *)
+                (* type_declaration list -> (string * type_kind) list *)
+                (List.map (fun {ptype_name = n; ptype_kind = k} ->
+                            (n.txt, get_type_value k)) tds) @
+                (get_construct rest)
+            | Pstr_exception ({pext_name = n; pext_kind = k}) ->
+                (* 例外の情報 *)
+                (n.txt, get_ext_value n.txt k) :: (get_construct rest)
+            | Pstr_module ({pmb_name = n; pmb_expr = e}) ->
+                (* モジュール名と中の式 *)
+                begin match e.pmod_desc with
+                  | Pmod_structure (strs) ->
+                    let pre_mod = get_construct
+                                    (List.map (fun x -> (x, Env.empty)) strs) in
+                    let a = List.map (fun (nk, kind) ->
+                                       (n.txt ^ "." ^ nk,
+                                        List.map (fun (nc, cts) ->
+                                                   (n.txt ^ "." ^ nc, cts))
+                                                 kind))
+                                     pre_mod in
+                    a @ (get_construct rest)
+                  | _ -> get_construct rest
+                end
+            | _ -> get_construct rest
+            end
+
+      (* kind の分解 *)
+      (* type_kind -> (string, core_type list) list *)
+      and get_type_value kind = match kind with
+        | Ptype_variant (cds) ->
+          List.map (fun {pcd_name = n; pcd_args = a} ->
+                     (n.txt, extract_core_types a)) cds
+        | _ -> []
+      (* extension_constructor_kind -> (string, core_type list) list *)
+      and get_ext_value name kind = match kind with
+        | Pext_decl (cts, None) ->
+          (* 引数を取る場合をとりあえず *)
+          [(name, extract_core_types cts)]
+        | _ -> [] in
+
+      print_loc expr.pexp_loc;
+      print_identified ();
+      print_illtyped_constructor lid (get_construct prefix) args
+
+  | Parsetree.Pexp_record (lst, None) -> (* illtyped *)
+      print_loc expr.pexp_loc;
+      print_identified ();
+(*
+      (* typs : エラーが出た箇所でのフィールドの型 *)
+      let typs = List.map (fun ({txt = t}, e) -> (snd (judge ((e, cxt), env, prefix))), t) lst in
+      (* exps : エラーが出た箇所での式 *)
+      let exps = List.map (fun (_, e) -> e) lst in
+ *)
+      (* 上記フィールドの名称を取得 *)
+
+      (* ダミーの型 *)
+      let dummy_exp =
+        { pexp_desc = Parsetree.Pexp_record
+                        (List.map (fun (lid, _) -> (lid, skeleton)) lst, None);
+          pexp_loc = Location.none;
+          pexp_attributes = [] } in
+      let dummy_t = snd (judge ((dummy_exp, cxt), env, prefix)) in
+
+      (* prefixからフィールドの中身を取り出す *)
+      let rec dummy_string d = match d with
+        | {desc = Tconstr (p, _, _)} -> Path.name p
+        | {desc = Tsubst (expr)} -> dummy_string expr
+        | {desc = Tlink (expr)} -> dummy_string expr (* #useで呼び出した場合 *)
+        | _ -> Format.fprintf ppf "%a@." Printtyp.type_expr d;  assert false in
+      let rec get_params tlst = match tlst with
+        | [] -> raise Not_found
+        | {ptype_name = {txt = t}; ptype_kind = Ptype_record llst} :: rest ->
+           if t = dummy_string dummy_t then llst else get_params rest
+        | _ :: rest -> get_params rest in
+      let rec search_rec p = match p with
+          [] -> assert false
+        | ({pstr_desc = Pstr_type (_, tlst)}, _) :: rest ->
+           begin
+             try get_params tlst with
+             Not_found -> search_rec rest
+           end
+        | _ :: rest -> search_rec rest in
+      (* 各フィールドの情報 *)
+      let fields =
+        List.map2 (fun ({txt = f}, e) ft ->
+                   ((f, ft), (e, snd (judge ((e, cxt), env, prefix)))))
+                  lst (search_rec prefix) in
+      print_illtyped_record dummy_t fields
+
+  | Parsetree.Pexp_constraint (exp, t) ->
+      print_loc expr.pexp_loc;
+      print_identified ();
+      let (_, typ1) = judge ((exp, cxt), env, prefix) in
+      let exp' = { pexp_desc = Parsetree.Pexp_constraint (skeleton, t);
+                   pexp_loc = Location.none;
+                   pexp_attributes = [] } in
+      let (_, typ2) = judge ((exp', cxt), env, prefix) in
+      print_illtyped_constraint typ1 typ2
+
+  | Parsetree.Pexp_array (es) ->
+      (* array に関するエラー *)
+      let typs =
+        List.map (fun exp -> snd (judge ((exp, cxt), env, prefix)))
+                 (List.filter (fun e -> e <> dummy_assertfalse e) es) in
+      let (typ1, typ2) = (List.nth typs 0, List.nth typs 1) in
+      print_loc expr.pexp_loc;
+      print_identified ();
+      print_illtyped_array typ1 typ2
+  | Parsetree.Pexp_let (flg, vs, _) ->
+      (* 再起関数の rec を忘れた場合 *)
+      print_loc expr.pexp_loc;
+      print_identified ();
+      if flg = Nonrecursive
+      then match vs with
+        | [] -> ()
+        | first :: rest -> print_illtyped_let first rest
+      else if List.length vs > 1
+      then print_illtyped_let_rec_many vs
+      else print_illtyped_let_rec1 (List.hd vs)
+  | _ -> (* illtyped *)
+       print_loc expr.pexp_loc;
+       print_identified ();
+       Format.fprintf ppf "default case of make_message_illtyped@.";
+       print_illtyped_other ()
+
+(* make_message_welltyped : expression context_t -> yes_no_list -> unit *)
+let make_message_welltyped ((expr, cxt), env, prefix) no =
+  (* 型エラーの原因と特定された式の型 *)
+  let (vartyps, t) = judge ((expr, cxt), env, prefix) in
+  let vartyps' = List.filter (fun (key, typ) -> answered_no key typ no env)
+                             vartyps in
+  print_loc expr.pexp_loc;
+  print_identified ();
+  match vartyps' with
+      [] -> (* 自由変数は意図通り *)
+        print_welltyped_expr t
+    | (((st, _), _, _), typ) :: [] -> (* 自由変数が意図通りでない *)
+        print_welltyped_env1 st typ
+    | (((st, _), _, _), typ) :: rest ->
+        print_welltyped_env_many st typ rest
+ *)
+
+(********** ask questions **********)
+
+(* ノード数カウント用の関数には全て node_count_ がついている *)
+
+(* node_count_ask_env :
+             (string context_t * type_expr) list -> Env.t ->
+             yes_no_list -> yes_no_list ->
+             int * yes_no_list * yes_no_list *)
+let rec node_count_ask_env vartyps env yes no = match vartyps with
+    [] -> (0, yes, no)
+  | (((st, _), _, _) as key, typ) :: rest ->
+      if Ctype.moregeneral env false typ (Btype.newgenvar ())
+      || answered_yes key typ yes env
+      then node_count_ask_env rest env yes no
+      else if answered_no key typ no env
+      then (0, yes, no)
+      else begin
+        (* 1 回聞き（yes を仮定してさらに）先を聞きにいく *)
+        if print_asked_expr then begin
+          Format.fprintf ppf "ask_env: %s@." st
+        end;
+        let (num, yes', no') =
+          node_count_ask_env rest env ((key, typ) :: yes) no in
+        (num + 1, yes', no')
+      end
+
+(* ask_env : expression -> (string context_t * type_expr) list -> Env.t ->
+             yes_no_list -> yes_no_list ->
+             bool * yes_no_list * yes_no_list *)
+let rec ask_env expr vartyps env yes no = match vartyps with
+    [] -> (true, yes, no)
+  | (((st, _), _, _) as key, typ) :: rest ->
+      if Ctype.moregeneral env false typ (Btype.newgenvar ())
+      || answered_yes key typ yes env
+      then ask_env expr rest env yes no
+      else if answered_no key typ no env
+      then (false, yes, no)
+      else (print_loc expr.pexp_loc;
+            print_ask_env st typ;
+            print_prompt ();
+            let input = read_line () in
+            Format.fprintf ppf "@.";
+            match input with
+                "y" | "y;;" -> ask_env expr rest env ((key, typ) :: yes) no
+              | "n" | "n;;"  -> (false, yes, (key, typ) :: no)
+              | _ -> raise DebuggerQuit)
+
+(* ask_expr_helper : expression -> type_expr -> Env.t ->
+                     yes_no_list -> yes_no_list ->
+                     bool * yes_no_list * yes_no_list *)
+let ask_expr_helper expr t env yes no =
+  if Ctype.moregeneral env false t (Btype.newgenvar ())
+  then (true, yes, no)
+  else
+    begin
+      if auto then (
+        print_loc expr.pexp_loc; print_ask_expr t; print_prompt ();
+        Format.fprintf ppf "@.";
+        (true, yes, no)
+      ) else (
+        print_loc expr.pexp_loc; print_ask_expr t; print_prompt ();
+        let input = read_line () in
+        Format.fprintf ppf "@.";
+        match input with
+        | "y" | "y;;" -> (true, yes, no)
+        | "n" | "n;;" -> (false, yes, no)
+        | _ -> raise DebuggerQuit (* 終わらせないようにしたい *)
+      ) end
+
+(* ask_expr : expression context_t -> type_expr -> Env.t ->
+              yes_no_list -> yes_no_list -> bool * yes_no_list * yes_no_list *)
+let ask_expr ((expr, _), _, _) t env yes no =
+  ask_expr_helper expr t env yes no
+
+(********** check whether expr has intended type **********)
+
+(* node_count_has_intended_type :
+     expression context_t -> yes_no_list -> yes_no_list ->
+     int * yes_no_list * yes_no_list *)
+let node_count_has_intended_type ((expr, cxt), env, prefix) yes no =
+  let (vartyps, typ) = judge ((expr, cxt), env, prefix) in
+  (* 以下は全部 yes と答えた場合のノード数を返す *)
+  let (num, yes', no') = node_count_ask_env vartyps env yes no in
+  (* 以下は ask_expr_helper に沿って書いてある *)
+  (* 全部 yes だと expr 自身も聞くので 1 を加えようとする *)
+  if Ctype.moregeneral env false typ (Btype.newgenvar ())
+  (* しかし型が 'a なら聞く必要がないので加えない *)
+  then (num, yes', no')
+  (* そうでなければ 1 加える *)
+  else begin
+    if print_asked_expr then begin
+      Format.fprintf ppf "has_intended_type:@.";
+      print_deb_exp ppf expr
+    end;
+    (num + 1, yes', no')
+  end
+  (* 返す yes', no' は全部 yes と答えた場合の返答 *)
+
+(* has_intended_type : expression context_t -> yes_no_list -> yes_no_list ->
+                       bool * yes_no_list * yes_no_list *)
+let has_intended_type ((expr, cxt), env, prefix) yes no =
+  let (vartyps, typ) = judge ((expr, cxt), env, prefix) in
+  let (b, yes', no') = ask_env expr vartyps env yes no in
+  if b
+  then ask_expr ((expr, cxt), env, prefix) typ env yes' no'
+  else (false, yes', no')
+
+(********** find the source of the type error **********)
+
+(* node_count_walk_right_typed :
+        expression context_t list -> yes_no_list -> yes_no_list -> int -> int *)
+let rec node_count_walk_right_typed progs yes no acc =
+  if acc >= 1000 then acc else match progs with
+    [] -> acc
+  | ((expr', _), _, _) :: rest
+      when expr' = hole_of_exp expr' ->
+      (* □ の中は数えないで次に行く *)
+      node_count_walk_right_typed rest yes no acc
+  | ((expr', cxt'), env', prefix') :: rest ->
+      (* このノードの質問の回数 *)
+      let (n1, yes', no') =
+        node_count_has_intended_type ((expr', cxt'), env', prefix')  yes no in
+      (* 以下の yes', no' は全て yes と答えてきた場合のもの *)
+      let n2 =
+        node_count_walk_right_typed rest yes' no' (acc + n1) in
+      (* no と答えた場合は、どこで no と答えたかわからないので困る *)
+      (* 以下は古い yes, no を使っている *)
+      (* つまり、no と答えた際の答えは再利用していないことになる *)
+      node_count_walk_up_typed ((expr', cxt'), env', prefix') yes no n2
+      (*
+      num (* このノードの質問の回数 *)
+      (* 以下の yes', no' は全て yes と答えてきた場合のもの *)
+      + node_count_walk_right_typed rest yes' no'
+      (* no と答えた場合は、どこで no と答えたかわからないので困る *)
+      (* 以下は古い yes, no を使っている *)
+      (* つまり、no と答えた際の答えは再利用していないことになる *)
+      + node_count_walk_up_typed ((expr', cxt'), env', prefix') yes no
+      *)
+
+(* node_count_walk_up_typed :
+        expression context_t -> yes_no_list -> yes_no_list -> int -> int *)
+and node_count_walk_up_typed ((expr, cxt), env, prefix) yes no acc =
+  (* ((expr, cxt), env, prefix) は well-typed *)
+  if acc >= 1000 then acc else
+  let progs = decompose_expr ((expr, cxt), env, prefix) Typed in
+  node_count_walk_right_typed progs yes no acc
+
+(* make_message_welltyped : expression context_t -> yes_no_list -> unit *)
+let make_message_welltyped ((expr, cxt), env, prefix) no =
+  (* 型エラーの原因と特定された式の型 *)
+  let (vartyps, t) = judge ((expr, cxt), env, prefix) in
+  let vartyps' = List.filter (fun (key, typ) -> answered_no key typ no env)
+                             vartyps in
+  print_loc expr.pexp_loc;
+  print_identified ();
+  match vartyps' with
+      [] -> (* 自由変数は意図通り *)
+        print_welltyped_expr t
+    | (((st, _), _, _), typ) :: [] -> (* 自由変数が意図通りでない *)
+        print_welltyped_env1 st typ
+    | (((st, _), _, _), typ) :: rest ->
+        print_welltyped_env_many st typ rest
+
+(* walk_right_typed :
+        expression context_t list -> yes_no_list -> yes_no_list ->
+        expression context_t option * yes_no_list * yes_no_list *)
+let rec walk_right_typed progs yes no = match progs with
+    [] -> (* All the premises are as intended. *)
+          (* The current expr is the source of the type error. *)
+      (None, yes, no)
+  | ((expr', cxt'), env', prefix') :: rest ->
+     if auto then
+       Format.fprintf ppf "ノード：@.%a@."
+                      Pprintast.expression expr';
+      let (intended, yes', no') =
+        has_intended_type ((expr', cxt'), env', prefix')  yes no in
+      if intended
+      then walk_right_typed rest yes' no'
+      else (Some ((expr', cxt'), env', prefix'), yes', no')
+
+(* walk_up_typed : expression context_t -> yes_no_list -> yes_no_list -> unit *)
+let rec walk_up_typed ((expr, cxt), env, prefix) yes no =
+  (* ((expr, cxt), env, prefix) は well-typed *)
+  let progs = decompose_expr ((expr, cxt), env, prefix) Typed in
+  let (c, yes', no') = walk_right_typed progs yes no in
+  begin match c with
+      None ->
+        (* 部分式の型は意図通り *)
+        make_message_welltyped ((expr, cxt), env, prefix) no'
+    | Some ((expr', cxt'), env', prefix') ->
+        (* 部分式の型が意図に合わない *)
+        walk_up_typed ((expr', cxt'), env', prefix') yes' no'
+  end
+
+(********** find the smallest illtyped pattern **********)
+
+(* walk_right_illtyped_pattern : pattern list context_t -> pattern option *)
+let rec walk_right_illtyped_pattern ((pats, cxt), env, prefix) =
+  match pats with
+    [] -> None
+  | pat :: rest ->
+      let exp = Exp.mk (Pexp_fun (Nolabel, None, pat, skeleton)) in
+      if is_well_typed_expr ((exp, cxt), env, prefix)
+      then walk_right_illtyped_pattern ((rest, cxt), env, prefix)
+      else Some (pat)
+
+(* walk_up_illtyped_pattern : pattern context_t -> unit *)
+let rec walk_up_illtyped_pattern ((pat, cxt), env, prefix) =
+  let pats = decompose_pattern pat in
+  match walk_right_illtyped_pattern ((pats, cxt), env, prefix) with
+      None -> (* 部分パターンは型がつく *) (* pat が型エラーの原因 *)
+        make_message_pattern ((pat, cxt), env, prefix)
+    | Some (pat) ->
+        walk_up_illtyped_pattern ((pat, cxt), env, prefix)
+
+(********** find the smallest illtyped expression **********)
+
+(* walk_right_illtyped :
+        expression context_t list -> yes_no_list -> yes_no_list ->
+        expression context_t option * yes_no_list * yes_no_list *)
+let rec walk_right_illtyped progs yes no = match progs with
+    [] -> (* all the decomposed programs are well typed *)
+      (None, yes, no)
+  | ((expr', cxt'), env', prefix') :: rest ->
+      if debug land 2 = 2 then Format.fprintf ppf "walk right illtyped:@.%a@."
+                                Pprintast.expression expr';
+      if is_well_typed_expr ((expr', cxt'), env', prefix')
+      then walk_right_illtyped rest yes no
+      else (Some ((expr', cxt'), env', prefix'), yes, no)
+
+(* walk_up_illtyped : expression context_t -> yes_no_list -> yes_no_list ->
+                      unit *)
+let rec walk_up_illtyped ((expr, cxt), env, prefix) yes no =
+  let pats = extract_pattern expr in
+  (* pattern に型がつくかを最初にチェック *)
+  match walk_right_illtyped_pattern ((pats, cxt), env, prefix) with
+      Some (pat) -> (* pat is illtyped *)
+        walk_up_illtyped_pattern ((pat, cxt), env, prefix)
+    | None -> (* patterns are all welltyped *)
+        let progs = decompose_expr ((expr, cxt), env, prefix) Illtyped in
+        let (c, yes', no') = walk_right_illtyped progs yes no in
+        begin match c with
+            None ->
+              if debug land 1 = 1 then
+                Format.fprintf ppf "illtyped expression:@.%a@."
+                  Pprintast.expression expr;
+              (* expr は illtyped だけど、子は全て welltyped になる *)
+              start_typed ((expr, cxt), env, prefix) yes' no'
+          | Some ((expr', cxt'), env', prefix') ->
+              walk_up_illtyped ((expr', cxt'), env', prefix') yes' no'
+        end
+
+(* start_typed : expression context_t -> yes_no_list -> yes_no_list -> unit *)
+and start_typed ((expr, cxt), env, prefix) yes no =
+  (* ((expr, cxt), env, prefix) 自身は ill-typed *)
+  (* decompose 結果は well-typed *)
+  match expr.pexp_desc with
+      Pexp_let (rec_flg, bindings, exp) ->
+        let exp0 = Exp.mk (Pexp_let (rec_flg, bindings, skeleton)) in
+        if is_well_typed_expr ((exp0, cxt), env, prefix) then
+          (* bindings に型がついたので、in 以下に進む *)
+          walk_up_illtyped
+            ((exp, Let (rec_flg, bindings, cxt)), env, prefix) yes no
+        else if rec_flg = Recursive then begin (* bindings 中の再帰が原因 *)
+          if debug land 1 = 1 then
+            Format.fprintf ppf "make message recursive:@.%a@."
+              Pprintast.expression expr;
+          make_message_recursive ((bindings, cxt), env, prefix)
+        end else (* パターン pats = exps が型エラーの原因 *)
+          make_message_bindings ((bindings, cxt), env, prefix)
+    | _ when print_node_count -> (* ノード数カウントの場合 *)
+        (* ノード数を数えて、ノード数を表示して終了 *)
+        let num =
+          node_count_walk_up_typed ((expr, cxt), env, prefix) yes no 0 in
+        (* Format.fprintf ppf "Number of visited nodes = %d@." num *)
+        Format.fprintf ppf ", %d" num
+    | _ -> (* let 文以外の式 *)
+(*
+        (* walk_up_typed をノード数を数えるように変更済み *)
+        (* それを呼び出して、ノード数を表示して終了 *)
+        let num = walk_up_typed ((expr, cxt), env, prefix) yes no in
+        Format.fprintf ppf "Number of visited nodes = %d@." num
+ *)
+       if auto then
+       Format.fprintf ppf "頂点のノード：@.%a@."
+                      Pprintast.expression expr;
+(*       let progs =  ((expr, cxt), env, prefix) in *)
+       let progs = decompose_expr ((expr, cxt), env, prefix) Typed in
+       let (c, yes', no') = walk_right_typed progs yes no in
+        begin match c with
+            None ->
+              (* 部分式の型は意図通り *)
+              if debug land 1 = 1 then
+                Format.fprintf ppf "make message illtyped:@.%a@."
+                  Pprintast.expression expr;
+              make_message_illtyped ((expr, cxt), env, prefix) (* yes' no' *)
+          | Some ((expr', cxt'), env', prefix') ->
+              (* 部分式の型が意図に合わない *)
+              if debug land 1 = 1 then Format.fprintf ppf "typed started:@.%a@."
+                                         Pprintast.expression expr';
+              walk_up_typed ((expr', cxt'), env', prefix') yes' no'
+        end
+
+(* make_message_illtyped : expression context_t -> unit *)
+and make_message_illtyped ((expr, cxt), env, prefix) (* yes no *) =
+  match expr.pexp_desc with
+    Parsetree.Pexp_ident (_) ->
+      print_loc expr.pexp_loc;
+      print_identified ();
+      print_illtyped_var_undefined ()
+  | Parsetree.Pexp_ifthenelse (exp1, exp2, None) ->
+      if not (is_bool_expr ((exp1, cxt), env, prefix)) then
+        (* predicate 部分が bool 型でない *)
+        let (_, typ1) = judge ((exp1, cxt), env, prefix) in begin
+          print_loc exp1.pexp_loc;
+          print_identified ();
+          print_illtyped_if_predicate typ1
+        end
+      else if not (is_unit_expr ((exp2, cxt), env, prefix)) then
+        (* then 部分が unit 型でない *)
+        let (_, typ2) = judge ((exp2, cxt), env, prefix) in begin
+          print_loc exp2.pexp_loc;
+          print_identified ();
+          print_illtyped_if_then typ2
+        end
+      else begin (* both are well_typed; conflicts in environment *)
+        print_loc expr.pexp_loc;
+        print_identified ();
+        print_illtyped_if_fv ()
+      end
+
+  | Parsetree.Pexp_ifthenelse (exp1, exp2, Some (exp3)) ->
+      if not (is_bool_expr ((exp1, cxt), env, prefix)) then
+        (* predicate 部分が bool 型でない *)
+        let (_, typ1) = judge ((exp1, cxt), env, prefix) in begin
+          print_loc exp1.pexp_loc;
+          print_identified ();
+          print_illtyped_if_predicate typ1
+        end
+      else (* [exp2; exp3] を同じリストに入れる *)
+        let mtloc = mknoloc (Longident.Lident "[]") in
+        let mt = Exp.mk (Pexp_construct (mtloc, None)) in
+        let consloc = mknoloc (Longident.Lident "::") in
+        let cons e1 e2 =
+          let e = Exp.mk (Pexp_tuple [e1; e2]) in
+          Exp.mk (Pexp_construct (consloc, Some e)) in
+        let exp' = cons exp2 (cons exp3 mt) in
+        if not (is_well_typed_expr ((exp', cxt), env, prefix)) then
+          (* then 部分と else 部分が同じ型でない *)
+          (* または then 部分と else 部分で環境の衝突が起きた *)
+          let (_, typ2) = judge ((exp2, cxt), env, prefix) in
+          let (_, typ3) = judge ((exp3, cxt), env, prefix) in begin
+            print_loc expr.pexp_loc;
+            print_identified ();
+            print_illtyped_if_then_else typ2 typ3
+          end
+        else begin (* if 文全体で環境の衝突が起きている *)
+          print_loc expr.pexp_loc;
+          print_identified ();
+          print_illtyped_if_fv ()
+        end
+
+  | Parsetree.Pexp_apply (exp, lexps) ->
+      let (_, exp_typ) = judge ((exp, cxt), env, prefix) in (* 関数の型 *)
+      let typs = List.map (fun (_, e) -> snd (judge ((e, cxt), env, prefix)))
+                          lexps in (* 引数の型 *)
+      let exps = List.map (fun (_, e) -> e) lexps in
+      if split_arrow exp_typ = None then begin
+        (* 関数部分が関数型になっていない *)
+        print_loc expr.pexp_loc;
+        print_identified ();
+        print_illtyped_apply_not_function exp_typ
+      end else
+        (* 型エラーを起こすことなく渡せる引数列と
+         * 型エラーを起こす最初の引数のペアを返す *)
+        let rec well_typed_args wargs lexps = match lexps with
+            [] ->
+              failwith "TypeDebugger: Error: apply in make_message_illtyped."
+          | first :: rest ->
+              let wargs' = wargs @ [first] in
+              let exp' = Exp.mk (Pexp_apply (exp, wargs')) in
+              if is_well_typed_expr ((exp', cxt), env, prefix)
+              then well_typed_args wargs' rest
+              else (wargs, first) in
+(*        let (wargs, (_, arg)) = well_typed_args [] lexps in *)
+        let (wargs, _) = well_typed_args [] lexps in
+        (* 何番目の引数が型エラーを引き起こすか *)
+        let n = List.length wargs + 1 in
+        (* 型エラーになる直前までの型 *)
+        let typ = if n = 1 then exp_typ
+                  else let wexp = Exp.mk (Pexp_apply (exp, wargs)) in
+                       snd (judge ((wexp, cxt), env, prefix)) in
+                       (* wargs = [] だと judge が syntax error を起こす *)
+        begin match split_arrow typ with
+            None -> (* typ が関数型でなかった：引数が多かった場合 *)
+              print_loc expr.pexp_loc;
+              print_identified ();
+              print_illtyped_too_much_args n exp_typ typs exp
+          | Some (t1, _) -> (* n 番目の引数が型エラー *)
+              print_loc expr.pexp_loc;
+              print_identified ();
+              if language_level < 2
+              then (* language_level < 2 では関数引数は不可 *)
+                (* let (_, n_typ) = judge ((arg, cxt), env, prefix) in *)
+                (* 型エラーの原因となっている引数の型 *)
+                let funtypes = find_funtype_args typs 1 in
+                (* 関数型になっている引数 *)
+                begin match funtypes with
+                    [] -> (* 関数型になっている引数なし *)
+                      (*print_illtyped_apply_beginning2 n exp exp_typ n_typ*)
+                    print_illtyped_apply_beginning2 n exp_typ exps typs t1 exp
+                  | _ -> (* 関数型になっている引数あり *)
+                      print_illtyped_apply_beginning n exp exp_typ typs funtypes
+                end
+              (* language_level >= 2 は関数引数可 *)
+              else
+                print_illtyped_apply_funname n exp_typ exps typs t1 exp
+        end
+
+  | Parsetree.Pexp_function (_) ->
+      print_illtyped_function ()
+
+  | Parsetree.Pexp_fun (_, _, p, e) ->
+     let case = {pc_lhs = p; pc_guard = None; pc_rhs = e} in
+     make_message_case ((case, cxt), env, prefix)
+
+  | Parsetree.Pexp_match (exp, cases) ->
+  (* Pexp_match の補助変数 ------------------------------------------------ *)
+      (* body と guard を無効にした cases *)
+      let pattern_only_cases =
+        List.map (fun {pc_lhs = pat; } ->
+                    {pc_lhs = pat; pc_guard = None; pc_rhs = skeleton})
+                 cases in
+      (* body のみを無効にした cases *)
+      let pattern_and_guard_cases =
+        List.map (fun {pc_lhs = pat; pc_guard = g; } ->
+                    {pc_lhs = pat; pc_guard = g; pc_rhs = skeleton})
+                 cases in
+
+  (* Pexp_match の補助関数 ------------------------------------------------ *)
+      (* pattern の型が合っているかを調べる *)
+      (* pattern をひとつずつ加えて、型がつかなくなるところを探す *)
+      let rec patterns_ok exp wcases cases = match cases with
+          [] -> true (* すべての case を入れて型がついた *)
+        | case :: rest ->
+            let wcases' = wcases @ [case] in
+            let exp' = Exp.mk (Pexp_match (exp, wcases')) in
+            if is_well_typed_expr ((exp', cxt), env, prefix)
+            then patterns_ok exp wcases' rest
+            else begin match wcases with
+                [] -> (* 最初の case が型エラー。exp と case が合わない*)
+                  let case' = Exp.mk (Pexp_function ([case])) in
+                  if debug land 8 = 8 then
+                    Format.fprintf ppf "message illtyped match1:@.%a@."
+                      Pprintast.expression case';
+                  (* 最初のパターンの型 *)
+                  let (_, pat_typ) = judge ((case', cxt), env, prefix) in
+                  begin match split_arrow pat_typ with
+                    Some (t1, _) ->
+                      (* exp の型 *)
+                      let (_, exp_typ) = judge ((exp, cxt), env, prefix) in
+                      print_loc expr.pexp_loc;
+                      print_identified ();
+                      print_illtyped_match_exp exp_typ t1;
+                      false
+                  | None -> (* Can't happen *)
+                      failwith "TypeDebugger: match2 in make_message_illtyped."
+                  end
+              | _ :: _ -> (* case 同士で型エラー *)
+                  let wcases' = Exp.mk (Pexp_function (wcases)) in
+                  (* 型が合っている case の型 *)
+                  let (_, ok_typ) = judge ((wcases', cxt), env, prefix) in
+                  let case' = Exp.mk (Pexp_function ([case])) in
+                  if debug land 8 = 8 then
+                    Format.fprintf ppf "message illtyped match3:@.%a@."
+                      Pprintast.expression case';
+                  (* 型が合わない case の型 *)
+                  let (_, notok_typ) = judge ((case', cxt), env, prefix) in
+                  begin match (split_arrow ok_typ, split_arrow notok_typ) with
+                    (Some (ok1, _), Some (notok1, _)) ->
+                      print_loc case.pc_lhs.ppat_loc;
+                      print_identified ();
+                      print_illtyped_match_left notok1 ok1;
+                      false
+                  | (_, _) -> (* Can't happen *)
+                      failwith "TypeDebugger: match4 in make_message_illtyped."
+                  end
+            end in
+      (* guard が全て bool かどうかを調べる *)
+      let guards_all_bool cases =
+        List.for_all
+          (function {pc_guard = None} -> true
+            | {pc_guard = Some (g)} ->
+                if is_bool_expr ((g, cxt), env, prefix)
+                then true
+                else begin
+                  let (_, g_typ) = judge ((g, cxt), env, prefix) in
+                  print_loc g.pexp_loc;
+                  print_identified ();
+                  print_guard g_typ;
+                  false
+                end)
+          cases in
+      (* guard と exp で環境が衝突していないかを調べる *)
+      let rec guards_ok_with_exp exp wcases cases = match cases with
+          [] -> true (* すべての case を入れて型がついた *)
+        | case :: rest ->
+            let wcases' = wcases @ [case] in
+            let exp' = Exp.mk (Pexp_match (exp, wcases')) in
+            if is_well_typed_expr ((exp', cxt), env, prefix)
+            then guards_ok_with_exp exp wcases' rest
+            else (* case に入っている guard で環境の衝突 *)
+              begin match case with
+                {pc_guard = None} -> (* Can't happen *)
+                  failwith "TypeDebugger: match5 in make_message_illtyped."
+              | {pc_guard = Some (g)} ->
+                  print_loc g.pexp_loc;
+                  print_identified ();
+                  print_guard_env ();
+                  false
+              end in
+      (* cases に型がつくかを順に調べる *)
+      (* 各ケースの型を独立に求め、その型が皆同じかを調べたい *)
+      (* すると、以後は、環境の衝突のみを考えれば良くなる *)
+      let rec cases_ok exp wcases cases = match cases with
+          [] -> true (* すべての case を入れて型がついた *)
+        | case :: rest ->
+            let wcases' = wcases @ [case] in
+            let exp' = Exp.mk (Pexp_match (exp, wcases')) in
+            if is_well_typed_expr ((exp', cxt), env, prefix)
+            then cases_ok exp wcases' rest
+            else (* case に入っている guard で環境の衝突 *)
+              begin match wcases with
+              | [] -> (* case がひとつ目からだめ *)
+                 (* exp と case で環境が conflict している *)
+                 (* print_loc expr.pexp_loc; *)
+                 (* print_identified (); *)
+                 (* print_illtyped_other (); (* メッセージを変えるべき *) *)
+                 (* false *)
+                 make_message_case ((case, cxt), env, prefix);
+                 false
+              | _ :: _ -> (* case の右辺の式、あるいは環境の衝突が原因 *)
+                  let wcases' = Exp.mk (Pexp_match (exp, wcases)) in
+                  if debug land 8 = 8 then
+                    Format.fprintf ppf "message illtyped match6:@.%a@."
+                      Pprintast.expression wcases';
+                  (* 型が合っている case の型 *)
+                  let (_, ok_typ) = judge ((wcases', cxt), env, prefix) in
+                  let case' = Exp.mk (Pexp_match (exp, [case])) in
+                  if debug land 8 = 8 then
+                    Format.fprintf ppf "message illtyped match7:@.%a@."
+                      Pprintast.expression case';
+                  (* 型が合わない case の型 *)
+                  begin try
+                    let (_, notok_typ) = judge ((case', cxt), env, prefix) in
+                    print_loc case.pc_rhs.pexp_loc;
+                    print_identified ();
+                    print_illtyped_match_right notok_typ ok_typ;
+                    false
+                  with _ -> (* 型エラーが起きた。環境が衝突している *)
+                    print_loc case.pc_rhs.pexp_loc;
+                    print_identified ();
+                    print_illtyped_match_right2 ();
+                    false
+                  end
+              end in
+
+  (* Pexp_match のメイン -------------------------------------------------- *)
+      if patterns_ok exp [] pattern_only_cases
+      && guards_all_bool pattern_and_guard_cases
+      && guards_ok_with_exp exp [] pattern_and_guard_cases
+      && cases_ok exp [] cases
+      then failwith "TypeDebugger: match is welltyped in make_message_illtyped."
+      else () (* error already reported in one of the predicates *)
+(*
+      (* exp は単独では型はついている。match 文全体では型はつかない *)
+      if debug land 8 = 8 then
+        Format.fprintf ppf "message illtyped match1:@.%a@."
+          Pprintast.expression exp;
+*)
+
+  | Parsetree.Pexp_try (exp, cases) ->
+  (* Pexp_try の補助変数 ------------------------------------------------ *)
+      (* body と guard を無効にした cases *)
+      let pattern_only_cases =
+        List.map (fun {pc_lhs = pat} ->
+                    {pc_lhs = pat; pc_guard = None; pc_rhs = skeleton})
+                 cases in
+      (* body のみを無効にした cases *)
+      let pattern_and_guard_cases =
+        List.map (fun {pc_lhs = pat; pc_guard = g} ->
+                    {pc_lhs = pat; pc_guard = g; pc_rhs = skeleton})
+                 cases in
+
+  (* Pexp_try の補助関数 ------------------------------------------------ *)
+      (* pattern の型が合っているかを調べる *)
+      (* pattern をひとつずつ加えて、型がつかなくなるところを探す *)
+      let rec patterns_ok exp wcases cases = match cases with
+          [] -> true (* すべての case を入れて型がついた *)
+        | case :: rest ->
+            let wcases' = wcases @ [case] in
+            let exp' = Exp.mk (Pexp_try (skeleton, wcases')) in
+            if is_well_typed_expr ((exp', cxt), env, prefix)
+            then patterns_ok exp wcases' rest
+            else begin match wcases with
+                [] -> true
+              | _ :: _ -> (* case 同士で型エラー *)
+                  let wcases' = Exp.mk (Pexp_function (wcases)) in
+                  (* 型が合っている case の型 *)
+                  let (_, ok_typ) = judge ((wcases', cxt), env, prefix) in
+                  let case' = Exp.mk (Pexp_function ([case])) in
+                  if debug land 8 = 8 then
+                    Format.fprintf ppf "message illtyped match3:@.%a@."
+                      Pprintast.expression case';
+                  (* 型が合わない case の型 *)
+                  let (_, notok_typ) = judge ((case', cxt), env, prefix) in
+                  begin match (split_arrow ok_typ, split_arrow notok_typ) with
+                    (Some (_, _), Some (notok1, _)) ->
+                      print_loc case.pc_lhs.ppat_loc;
+                      print_identified ();
+                      print_illtyped_try_left notok1;
+                      false
+                  | (_, _) -> (* Can't happen *)
+                      failwith "TypeDebugger: match4 in make_message_illtyped."
+                  end
+            end in
+      (* guard が全て bool かどうかを調べる *)
+      let guards_all_bool cases =
+        List.for_all
+          (function {pc_guard = None} -> true
+            | {pc_guard = Some (g)} ->
+                if is_bool_expr ((g, cxt), env, prefix)
+                then true
+                else begin
+                  let (_, g_typ) = judge ((g, cxt), env, prefix) in
+                  print_loc g.pexp_loc;
+                  print_identified ();
+                  print_guard g_typ;
+                  false
+                end)
+          cases in
+      (* guard と exp で環境が衝突していないかを調べる *)
+      let rec guards_ok_with_exp exp wcases cases = match cases with
+          [] -> true (* すべての case を入れて型がついた *)
+        | case :: rest ->
+            let wcases' = wcases @ [case] in
+            let exp' = Exp.mk (Pexp_try (exp, wcases')) in
+            if is_well_typed_expr ((exp', cxt), env, prefix)
+            then guards_ok_with_exp exp wcases' rest
+            else (* case に入っている guard で環境の衝突 *)
+              begin match case with
+                {pc_guard = None} -> (* Can't happen *)
+                  failwith "TypeDebugger: match5 in make_message_illtyped."
+              | {pc_guard = Some (g)} ->
+                  print_loc g.pexp_loc;
+                  print_identified ();
+                  print_guard_env ();
+                  false
+              end in
+      (* cases に型がつくかを順に調べる *)
+      (* 各ケースの型を独立に求め、その型が皆同じかを調べたい *)
+      (* すると、以後は、環境の衝突のみを考えれば良くなる *)
+      let rec cases_ok exp wcases cases = match cases with
+          [] -> true (* すべての case を入れて型がついた *)
+        | case :: rest ->
+            let wcases' = wcases @ [case] in
+            let exp' = Exp.mk (Pexp_try (exp, wcases')) in
+            if is_well_typed_expr ((exp', cxt), env, prefix)
+            then cases_ok exp wcases' rest
+            else (* case に入っている guard で環境の衝突 *)
+              begin match wcases with
+                [] | [_] | _ -> (* case がひとつ目からだめ *)
+                let case' = Exp.mk (Pexp_function ([case])) in
+                if debug land 8 = 8 then
+                  Format.fprintf ppf "message illtyped match1:@.%a@."
+                                 Pprintast.expression case';
+                (* 最初のパターンの型 *)
+                let (_, pat_typ) = judge ((case', cxt), env, prefix) in
+                begin match split_arrow pat_typ with
+                    Some (_, t2) ->
+                      (* exp の型 *)
+                      let (_, exp_typ) = judge ((exp, cxt), env, prefix) in
+                      let case_loc = (case.pc_rhs).pexp_loc in
+                      print_loc case_loc;
+                      print_identified ();
+                      (* 環境の衝突かどうかを確認 *)
+                      (try
+                          (Ctype.unify env exp_typ t2;
+                           print_illtyped_try_env ();
+                           false)
+                        with
+                          _ -> print_illtyped_try_right exp_typ t2;
+                      (* try文の式と矢印の右側の型が合わない *)
+                      false)
+                  | None -> (* Can't happen *)
+                      failwith "TypeDebugger: match2 in make_message_illtyped."
+                end
+              end in
+
+  (* Pexp_try のメイン -------------------------------------------------- *)
+      let exn_case =
+        [{ pc_lhs = { ppat_desc = Ppat_construct
+                                    ({txt = Longident.Lident ("Not_found");
+                                      loc = Location.none},
+                                     None);
+                      ppat_loc = Location.none;
+                      ppat_attributes = [] };
+           pc_guard = None;
+           pc_rhs = skeleton }] in
+      if (patterns_ok exp exn_case pattern_only_cases)
+      && (guards_all_bool pattern_and_guard_cases)
+      && (guards_ok_with_exp exp [] pattern_and_guard_cases)
+      && (cases_ok exp [] cases)
+      then failwith "TypeDebugger: match is welltyped in make_message_illtyped."
+      else () (* error already reported in one of the predicates *)
+
+  | Parsetree.Pexp_construct ({txt = lid}, e) ->
+      (* 引数の情報 *)
+      let args =
+        List.map (fun (e, t) ->
+                   if e = hole_of_exp e then None else Some (e, t))
+          (match e with
+            | Some (exp) ->
+               let typ = snd (judge ((exp, cxt), env, prefix)) in
+               begin
+                 (* 引数の数をチェック *)
+                 match (decode_tuple typ) with
+                 | Some (typs) ->
+                    let exps = match exp.pexp_desc with
+                      | Pexp_tuple (es) -> es
+                      | _ -> assert false in
+                    List.combine exps typs
+                 | None -> [(exp, typ)]
+               end
+            | None -> []) in
+
+      (* extract core type list from constructor arguments *)
+      (* extract_core_types : constructor_arguments -> core_type list *)
+      let extract_core_types carg = match carg with
+        | Pcstr_tuple (cts) -> cts
+        | Pcstr_record (_) -> assert false (* not supported yet *)
+      in
+
+      (* prefix の分解 *)
+      (* prefix -> (string * kind) list *)
+      let rec get_construct prefix = match prefix with
+        | [] -> []
+        | (first, _) :: rest ->
+            begin match first.pstr_desc with
+            | Pstr_type (_, tds) ->
+                (* 型の情報 *)
+                (* type_declaration list -> (string * type_kind) list *)
+                (List.map (fun {ptype_name = n; ptype_kind = k} ->
+                            (n.txt, get_type_value k)) tds) @
+                (get_construct rest)
+            | Pstr_exception ({pext_name = n; pext_kind = k}) ->
+                (* 例外の情報 *)
+                (n.txt, get_ext_value n.txt k) :: (get_construct rest)
+            | Pstr_module ({pmb_name = n; pmb_expr = e}) ->
+                (* モジュール名と中の式 *)
+                begin match e.pmod_desc with
+                  | Pmod_structure (strs) ->
+                    let pre_mod = get_construct
+                                    (List.map (fun x -> (x, Env.empty)) strs) in
+                    let a = List.map (fun (nk, kind) ->
+                                       (n.txt ^ "." ^ nk,
+                                        List.map (fun (nc, cts) ->
+                                                   (n.txt ^ "." ^ nc, cts))
+                                                 kind))
+                                     pre_mod in
+                    a @ (get_construct rest)
+                  | _ -> get_construct rest
+                end
+            | _ -> get_construct rest
+            end
+
+      (* kind の分解 *)
+      (* type_kind -> (string, core_type list) list *)
+      and get_type_value kind = match kind with
+        | Ptype_variant (cds) ->
+          List.map (fun {pcd_name = n; pcd_args = a} ->
+                     (n.txt, extract_core_types a)) cds
+        | _ -> []
+      (* extension_constructor_kind -> (string, core_type list) list *)
+      and get_ext_value name kind = match kind with
+        | Pext_decl (cts, None) ->
+          (* 引数を取る場合をとりあえず *)
+          [(name, extract_core_types cts)]
+        | _ -> [] in
+
+      print_loc expr.pexp_loc;
+      print_identified ();
+      print_illtyped_constructor lid (get_construct prefix) args
+
+  | Parsetree.Pexp_record (lst, None) -> (* illtyped *)
+      print_loc expr.pexp_loc;
+      print_identified ();
+(*
+      (* typs : エラーが出た箇所でのフィールドの型 *)
+      let typs = List.map (fun ({txt = t}, e) -> (snd (judge ((e, cxt), env, prefix))), t) lst in
+      (* exps : エラーが出た箇所での式 *)
+      let exps = List.map (fun (_, e) -> e) lst in
+ *)
+      (* 上記フィールドの名称を取得 *)
+
+      (* ダミーの型 *)
+      let dummy_exp =
+        { pexp_desc = Parsetree.Pexp_record
+                        (List.map (fun (lid, _) -> (lid, skeleton)) lst, None);
+          pexp_loc = Location.none;
+          pexp_attributes = [] } in
+      let dummy_t = snd (judge ((dummy_exp, cxt), env, prefix)) in
+
+      (* prefixからフィールドの中身を取り出す *)
+(*
+      let rec dummy_string d = match d with
+        | {desc = Tconstr (p, _, _)} -> Path.name p
+        | {desc = Tsubst (expr)} -> dummy_string expr
+        | {desc = Tlink (expr)} -> dummy_string expr (* #useで呼び出した場合 *)
+        | _ -> Format.fprintf ppf "%a@." Printtyp.type_expr d;  assert false in
+      let rec get_params tlst = match tlst with
+        | [] -> raise Not_found
+        | {ptype_name = {txt = t}; ptype_kind = Ptype_record llst} :: rest ->
+           if t = dummy_string dummy_t then llst else get_params rest
+        | _ :: rest -> get_params rest in
+      let rec search_rec p = match p with
+          [] -> assert false
+        | ({pstr_desc = Pstr_type (_, tlst)}, _) :: rest ->
+           begin
+             try get_params tlst with
+             Not_found -> search_rec rest
+           end
+        | _ :: rest -> search_rec rest in
+ *)
+      (* 各フィールドの情報 *)
+      let fields =
+        List.map2 (fun ({txt = f}, e) ft ->
+                   ((f, ft), (e, snd (judge ((e, cxt), env, prefix)))))
+                  lst (decode_labels dummy_t prefix) in
+      print_illtyped_record dummy_t fields
+
+  | Parsetree.Pexp_constraint (exp, t) ->
+      print_loc expr.pexp_loc;
+      print_identified ();
+      let (_, typ1) = judge ((exp, cxt), env, prefix) in
+      let exp' = { pexp_desc = Parsetree.Pexp_constraint (skeleton, t);
+                   pexp_loc = Location.none;
+                   pexp_attributes = [] } in
+      let (_, typ2) = judge ((exp', cxt), env, prefix) in
+      print_illtyped_constraint typ1 typ2
+
+  | Parsetree.Pexp_array (es) ->
+      (* array に関するエラー *)
+      let typs =
+        List.map (fun exp -> snd (judge ((exp, cxt), env, prefix)))
+                 (List.filter (fun e -> e <> hole_of_exp e) es) in
+      let (typ1, typ2) = (List.nth typs 0, List.nth typs 1) in
+      print_loc expr.pexp_loc;
+      print_identified ();
+      print_illtyped_array typ1 typ2
+  | Parsetree.Pexp_let (flg, vs, _) ->
+      (* 再起関数の rec を忘れた場合 *)
+      print_loc expr.pexp_loc;
+      print_identified ();
+      if flg = Nonrecursive
+      then match vs with
+        | [] -> ()
+        | first :: rest -> print_illtyped_let first rest
+      else if List.length vs > 1
+      then print_illtyped_let_rec_many vs
+      else print_illtyped_let_rec1 (List.hd vs)
+  | _ -> (* illtyped *)
+       print_loc expr.pexp_loc;
+       print_identified ();
+       Format.fprintf ppf "default case of make_message_illtyped@.";
+       print_illtyped_other ()
+
+(********** find the smallest illtyped structure **********)
+
+(* expr_of_structure : structure_item -> expression * expr_context *)
+let expr_of_structure structure_item = match structure_item with
+  | { pstr_desc = Pstr_eval (expr, _) } ->
+      (expr, Empty)
+  | { pstr_desc = Pstr_value (flg, bindings); pstr_loc = loc } ->
+      (* in なしの let 文 *)
+      ({ pexp_desc       = Pexp_let (flg, bindings, skeleton);
+         pexp_loc        = loc;
+         pexp_attributes = [] }, Empty)
+  | _ -> failwith "TypeDebugger: Error: this structure not supported."
+
+(* illtyped_expr : structure -> Env.t -> str_context -> expression context_t *)
+(* structure has to be ill-typed. *)
+let rec illtyped_expr structure env lst = match structure with
+    [] -> failwith "TypeDebugger: Error: structure is well typed."
+  | s :: rest ->
+      begin try
+        let (_, _, env') = Typemod.type_structure env [s] Location.none in
+        illtyped_expr rest env' ((s, env) :: lst)
+      with Typecore.Error (_, _, Typecore.Expr_type_clash (_))
+         | Typecore.Error (_, _, Typecore.Pattern_type_clash (_))
+         | _ (* Unbound value *)
+         -> (match s with 
+               { pstr_desc = Pstr_module ({pmb_expr = {pmod_desc =  Pmod_structure(structure)}})} -> illtyped_expr structure env lst
+             | _ -> (expr_of_structure s, env, lst))
+      end
+
+(********** main entry point **********)
+
+(* check_let_rec1 : value_binding -> Env.t -> value_binding list * int *)
+let check_let_rec1 vb env =
+  try
+    ignore(Typemod.type_structure env [{ pstr_desc = Pstr_value (Recursive, [vb]); pstr_loc  = Location.none }] Location.none);
+    (* エラーにならなければ単独再帰の rec つけ忘れ *)
+    if print_slice
+    then Format.fprintf ppf "@[This error is let_rec1.@]@.";
+    ([vb], 1)
+  with
+  | _ -> ([], 0)
+(* check_let_rec_many :
+     value_binding list -> Env.t -> value_binding list * int *)
+and check_let_rec_many vs_f env =
+  try
+    ignore(Typemod.type_structure env [{ pstr_desc = Pstr_value (Recursive, vs_f); pstr_loc  = Location.none }] Location.none);
+    (* 相互再帰の rec つけ忘れ *)
+    if print_slice
+    then Format.fprintf ppf "@[This error is let_rec_many.@]@.";
+    (vs_f, 2)
+  with
+  | _ -> ([], 0)
+(* check_let :
+     value_binding -> value_binding list -> Env.t -> value_binding list * int *)
+and check_let vb vs_b env =
+  try
+    ignore(Typemod.type_structure env [{ pstr_desc = Pstr_eval ({pexp_desc = Pexp_let (Nonrecursive, vs_b, {pexp_desc = Pexp_let (Nonrecursive, [vb], skeleton); pexp_loc = Location.none; pexp_attributes = []; }); pexp_loc = Location.none; pexp_attributes = []; }, []); pstr_loc  = Location.none }] Location.none);
+    (* and じゃなくて in で書くべき場面 *)
+    if print_slice
+    then Format.fprintf ppf "@[This error is let.@]@.";
+    (vb :: vs_b, 3)
+  with
+  | _ -> ([], 0)
+
+(* unbound_vb : value_binding list ->
+                value_binding list -> Env.t -> value_binding list * int *)
+let rec unbound_vb vs_f vs_b env = match vs_f with
+  (* エラーの原因になっている value binding を返す *)
+  | [] -> ([], 0)
+  | first :: rest ->
+     try
+       (* first の式部分がエラーになるかどうか *)
+       ignore(Typemod.type_structure env [{ pstr_desc = Pstr_eval (first.pvb_expr, []); pstr_loc  = Location.none }] Location.none);
+       (* エラーにならなければ次に進む *)
+       unbound_vb rest (first :: vs_b) env
+     with
+     | _ ->
+        (* let文のエラーをチェック *)
+        let (vs, num) =
+          check_let_rec1 first env in
+        let (vs, num) =
+          if num > 0 then (vs, num) else check_let_rec_many vs_f env in
+        let (vs, num) =
+          if num > 0 then (vs, num) else check_let first vs_b env in
+        (* 結果 *)
+        (vs, num)
+(* search : expression -> Env.t -> expression *)
+and search exp env = match exp.pexp_desc with
+  (* rec のつけ忘れがあれば該当する構文を返す *)
+  (* なければ □ を返す *)
+  | Pexp_let (flg, vs, e) ->
+     let exp' = search e env in
+     let (vs', num) =
+       if flg = Recursive then ([], 0) else unbound_vb vs [] env in
+     (* 結果を元に返す式を決める *)
+     if num > 0
+     then
+       let flg' =
+         if num = 3 then Nonrecursive else Recursive in
+       let d =
+         Pexp_let (flg', vs', e) in
+       {pexp_desc = d;
+        pexp_loc = exp.pexp_loc;
+        pexp_attributes = exp.pexp_attributes; }
+     else if exp' = hole_of_exp exp'
+     then hole_of_exp exp
+     else exp'
+  | Pexp_ifthenelse (e1, e2, e') ->
+     let es = e1 :: e2 :: match e' with None -> [] | Some e3 -> [e3] in
+     search' skeleton es env
+  | Pexp_match (e, cs) ->
+     search' (search e env) (List.map (fun {pc_rhs = e} -> e) cs) env
+  | Pexp_try (e, cs) ->
+     search' (search e env) (List.map (fun {pc_rhs = e} -> e) cs) env
+  | Pexp_apply (e, les) ->
+     search' (search e env) (List.map (fun (_, e) -> e) les) env
+  | Pexp_function (cs) ->
+     search' skeleton (List.map (fun {pc_rhs = e} -> e) cs) env
+  | Pexp_record (les, _) ->
+     search' skeleton (List.map (fun (_, e) -> e) les) env
+  | Pexp_tuple (es) -> search' skeleton es env
+  | Pexp_array (es) -> search' skeleton es env
+  | Pexp_construct (_, Some e) -> search e env
+  | Pexp_fun (_, None, _, e) -> search e env
+  | Pexp_constraint (e, _) -> search e env
+  | _ -> hole_of_exp exp
+(* search' : expression -> expression list -> Env.t -> expression *)
+and search' dummy lst env =
+  List.fold_left (
+      fun e' fst ->
+      if e' = hole_of_exp e' then search fst env else e'
+    ) dummy lst
+
+(*
+let get_type_expr ((expr, cxt), env, prefix) =
+  try
+    (* expr(fun文)の型を求める *)
+    let (_, typ) = judge ((expr, cxt), env, prefix) in
+    begin
+      match split_arrow typ with
+      | Some (t, _) -> Some (t)
+      | None -> Some (typ)
+    end
+  with _ -> None
+
+(* レコードの補完 *)
+(* complete_pat_record : expression context_t
+   -> (Longident.t loc * pattern) list -> pattern_desc *)
+let complete_pat_record ((expr, cxt), env, prefix) (lps, flg) =
+  match get_type_expr ((expr, cxt), env, prefix) with
+  | None -> Ppat_any
+  | Some (dummy_t) ->
+     (* レコードのパターンの置き換えを行う *)
+     (* 各フィールドのダミーを作る *)
+     let dummy_lps =
+       List.map (
+           fun {pld_name = {txt = t; loc = l}} ->
+           ({txt = Longident.parse t; loc = l}, Debug_core.wildcard)
+         ) (decode_labels dummy_t prefix) in
+     (* lps の要素を順に dummy_lps に当てはめていく *)
+     let lps' =
+       List.fold_left (
+           (* lst : 置き換えの対象 *)
+           (* (ln, pn) : パターン中の一要素 *)
+           fun lst (ln, pn) ->
+           List.map (
+               fun (lm, pm) ->
+               if Longident.last lm.txt = Longident.last ln.txt
+               then (ln, pn) else (lm, pm)) lst
+         ) dummy_lps lps in
+     (* record の desc を返す *)
+     Ppat_record (lps', flg)
+
+let dummy_fun pat =
+  Debug_core.desc_to_exp (Pexp_fun (Nolabel, None, pat, skeleton)) skeleton
+
+let complete_pat ((expr, cxt), env, prefix) pat =
+  match pat.ppat_desc with
+  | Ppat_record (lps, flg) ->
+     (* レコード *)
+     (* 足りないフィールドを補う *)
+     Debug_core.desc_to_pat (complete_pat_record ((expr, cxt), env, prefix) (lps, flg)) pat
+  | _ -> pat
+
+(* パターンの補完を行う関数 *)
+let rec complete ((expr, cxt), env, prefix) =  match expr.pexp_desc with
+  | Pexp_fun (l, eop, pat, exp) ->
+     (* fun P -> E *)
+     (* Pの型をチェックする *)
+     let exp' = complete ((exp, cxt), env, prefix) in
+     let pat' = complete_pat ((exp, cxt), env, prefix) pat in
+
+(*
+     let pat' = match pat.ppat_desc with
+       | Ppat_record (lps, flg) ->
+          (* E を □ に置き換える *)
+          let d = Pexp_fun (Nolabel, None, pat, skeleton) in
+          let dummy_e = Debug_core.desc_to_exp d expr in
+          (* Pのフィールドを補完する *)
+          Debug_core.desc_to_pat (complete_pat_record ((dummy_e, cxt), env, prefix) (lps, flg)) pat
+       | _ -> pat in
+ *)
+     let d' = Pexp_fun (l, eop, pat', exp') in
+     Debug_core.desc_to_exp d' expr
+(*     Debug_core.compare_expr (Debug_core.desc_to_exp d') expr *)
+  | Pexp_apply (e0, les) ->
+     (* E0 E1 E2 ... *)
+     let e0' = complete ((e0, cxt), env, prefix) in
+     let les' =
+       List.map (
+           fun (l, en) -> (l, complete ((en, cxt), env, prefix))) les in
+     let d' = Pexp_apply (e0', les') in
+(*     Debug_core.compare_expr (Debug_core.desc_to_exp d') expr *)
+     Debug_core.desc_to_exp d' expr
+  | Pexp_match (e, cs) ->
+     (* match E0 with P1 -> E1 | ... *)
+     (* csに含まれるパターン全てに対して同じように処理する *)
+     let cs' =
+       List.map (
+           fun ({pc_lhs = pat; pc_guard = g; pc_rhs = exp}) ->
+           let exp' = dummy_fun pat in
+           let pat' = complete_pat ((exp', cxt), env, prefix) pat in
+           {pc_lhs = pat'; pc_guard = g; pc_rhs = exp}
+         ) cs in
+     let d' = Pexp_match (e, cs') in
+     Debug_core.desc_to_exp d' expr
+(*
+     Debug_core.compare_expr (Debug_core.desc_to_exp d') expr
+ *)
+  | _ -> expr
+*)
+
+(* algo : structure -> Env.t -> unit *)
+(* structure contains all the program to be compiled *)
+(* toplevel_env is always the clean initial environment *)
+let algo structure toplevel_env =
+(*
+  if Debug_core.print_slice
+  then (
+    Format.fprintf ppf "@[algo: \n @.%a@.@]@." Pprintast.structure structure
+  );
+ *)
+  Warnings.parse_options false "-A";
+  if not print_node_count then print_initial_message ();
+(*
+  match phr with
+    Ptop_dir (_, _) ->
+      failwith "TypeDebugger: Error: Ptop_dir is passed to algo."
+  | Ptop_def (structure) ->
+*)
+      (* obtain the smallest illtyped structure *)
+  let ((expr, cxt), env, prefix) =
+    illtyped_expr structure toplevel_env [] in
+  if debug land 1 = 1 then Format.fprintf ppf "starting structure:@.%a@." Pprintast.structure structure;
+  if debug land 1 = 1 then Format.fprintf ppf "illtyped structure:@.%a@." Pprintast.expression expr;
+(*
+  if false (* !Debug_core.error_kind = "Typetexp" *)
+  then
+    (* let 文のエラー判定 *)
+    let expr' = search expr env in
+    if expr' = dummy_assertfalse expr'
+    then make_message_illtyped ((expr, cxt), env, prefix) (* [] [] *)
+    else make_message_illtyped ((expr', cxt), env, prefix) (* [] [] *)
+  else
+ *)
+  (* 通常のデバッグ *)
+  try
+    (* デバッガ起動 *)
+    (* 簡単なエラーでなければ、パターンの補完を行う *)
+    if print_slice
+    then Format.fprintf ppf 
+                        "@[~algo~\
+                         @.  %a @]@." Pprintast.expression expr;
+    walk_up_illtyped ((expr, cxt), env, prefix) [] [];
+    Warnings.parse_options false Warnings.defaults_w
+  with
+  | DebuggerQuit ->
+      Warnings.parse_options false Warnings.defaults_w
+  | Syntaxerr.Error (Syntaxerr.Unclosed _) -> assert false
+  | Syntaxerr.Error (Syntaxerr.Expecting _) -> assert false
+  | Syntaxerr.Error (Syntaxerr.Not_expecting _) -> assert false
+  | Syntaxerr.Error (Syntaxerr.Applicative_path _) -> assert false
+  | Syntaxerr.Error (Syntaxerr.Variable_in_scope _) -> assert false
+  | Syntaxerr.Error (Syntaxerr.Expert_exp _) -> assert false
+  | Syntaxerr.Error (Syntaxerr.InfixOP0 _) -> assert false
+  | Syntaxerr.Error (Syntaxerr.Other _) -> assert false
+  | Syntaxerr.Error (Syntaxerr.Ill_formed_ast _) -> assert false
+  | err ->
+      Warnings.parse_options false Warnings.defaults_w;
+      raise err
+
+(* illtyped_structure_prefix : structure -> Env.t -> structure * structure *)
+(* structure has to be ill-typed. *)
+(* toplevel_env is always the clean initial environment *)
+(* returns (str, rev_str) where rev_str is well typed but str is ill typed *)
+let illtyped_structure_prefix structure toplevel_env =
+  let ((expr, cxt), _, prefix) = illtyped_expr structure toplevel_env [] in
+  (plug_str (expr, cxt), List.map fst prefix)
+
+(* handle_simple_errors : Format.formatter -> exn ->
+                          structure -> (unit -> Env.t) -> bool *)
+(* 簡単なエラーはここで処理して true を返す *)
+(* 処理しなかった場合は false を返す *)
+let handle_simple_errors ppf x structure init_env =
+  let finished = ref true in
+  (* typecore のエラー *)
+  let typecore error =
+    (* Debug_core.error_kind := "Typecore"; *)
+    if print_ocaml_error then Location.report_exception ppf x;
+    match error with
+    | Typecore.Wrong_name (_, typ, kind, _, name, _) ->
+        (* レコードもしくはコンストラクタに属していない引数がある *)
+        Debug_message.print_identified ();
+        Debug_message.print_wrong_name kind typ name
+    | Typecore.Label_missing (labels) ->
+        (* フィールド不足 *)
+        Debug_message.print_identified ();
+        Debug_message.print_label_missing labels
+    | Typecore.Label_multiply_defined (name) ->
+        (* 同一レコード内のフィールド多重定義 *)
+        Debug_message.print_identified ();
+        Debug_message.print_label_mul name
+    | Typecore.Undefined_method (_, "use", _) ->
+        (* #useが文の途中にある *)
+        Debug_message.print_identified ();
+        Debug_message.print_no_method_use ()
+    | Typecore.Orpat_vars (_) ->
+        (* 変数を含む複数のパターンが同じ式に至る *)
+        Debug_message.print_identified ();
+        Debug_message.print_orpad_vars ()
+    | Typecore.Multiply_bound_variable (s) ->
+        (* ひとつのパターンマッチに同じ変数が複数回現れている *)
+        Debug_message.print_identified ();
+        Debug_message.print_multiply_bound_variable s
+    | _ -> finished := false (* type debugger will be launched later *)
+  (* typedecl のエラー *)
+  and typedecl error =
+    (* Debug_core.error_kind := "Typedecl"; *)
+    if print_ocaml_error then Location.report_exception ppf x;
+    match error with
+    | Typedecl.Duplicate_constructor s ->
+        (* 二重定義・コンストラクタ *)
+        Debug_message.print_identified ();
+        Debug_message.print_duplicate_name "constructor" s
+    | Typedecl.Duplicate_label s ->
+        (* 二重定義・レコード *)
+        Debug_message.print_identified ();
+        Debug_message.print_duplicate_name "record" s
+    | _ -> Location.report_exception ppf x
+  (* typetexp のエラー *)
+  and typetexp error =
+    (* Debug_core.error_kind := "Typetexp"; *)
+    if print_ocaml_error then Location.report_exception ppf x;
+    match error with
+    | Typetexp.Unbound_value (_) ->
+        (* 未定義：変数 *)
+        let ((expr, cxt), env, prefix) =
+          illtyped_expr structure (init_env ()) [] in
+        let expr' = search expr env in
+        if expr' = hole_of_exp expr'
+        then (* make_message_illtyped ((expr, cxt), env, prefix) *)
+             finished := false
+        else make_message_illtyped ((expr', cxt), env, prefix) (* [] [] *)
+
+    | Typetexp.Unbound_constructor (lid) ->
+       (* 未定義：コンストラクタ *)
+       Debug_message.print_identified ();
+       Debug_message.print_unbound_name "construct" lid
+
+    | Typetexp.Unbound_label (lid) ->
+       (* 未定義：フィールド *)
+       Debug_message.print_identified ();
+       Debug_message.print_unbound_name "record" lid
+
+    | Typetexp.Unbound_module (lid) ->
+       (* 未定義：モジュール *)
+       Debug_message.print_identified ();
+       Debug_message.print_unbound_name "module" lid
+
+    | _ -> Location.report_exception ppf x 
+  in begin
+      match x with
+      | Typecore.Error (_, _, error) -> typecore error
+      | Typedecl.Error (_, error) -> typedecl error
+      | Typetexp.Error (_, _, error) -> typetexp error
+      | _ -> Location.report_exception ppf x
+    end; !finished
+
+(* launch : structure -> (unit -> Env.t) -> unit *)
+let launch strs initial_env =
+  (* structure *)
+  if print_node_count then begin
+      let (last_str, rev_str) =
+        illtyped_structure_prefix ([hole_str]@strs) (initial_env ()) in
+      let strs = List.rev_append rev_str last_str in
+
+      (* スライス前のノード数も数える *)
+      algo strs (initial_env ());
+      (* パターン以外のスライス後のノード数も数える *)
+      on_pat_slice := false;
+      let slice = Debug_slice.get_slice_top strs (initial_env ()) in
+      let strs = List.rev_append rev_str slice in
+      algo strs (initial_env ());
+      on_pat_slice := true
+    end;
+  (* スライスの有無を切り替える *)
+  let strs = 
+    if on_slice
+    then Debug_slice.get_slice_top strs (initial_env ())
+    else strs in
+
+  if print_slice
+  then Format.fprintf ppf "@[launch: @,\
+                           %a @]@." print_deb_strs strs;
+
+  algo strs (initial_env ())
diff --git a/typing/debug_main.mli b/typing/debug_main.mli
new file mode 100644
index 0000000..fb5a3d5
--- /dev/null
+++ b/typing/debug_main.mli
@@ -0,0 +1,5 @@
+open Parsetree
+
+val handle_simple_errors : Format.formatter -> exn ->
+                           structure -> (unit -> Env.t) -> bool
+val launch : structure -> (unit -> Env.t) -> unit
diff --git a/typing/debug_message.ml b/typing/debug_message.ml
new file mode 100644
index 0000000..3d55d49
--- /dev/null
+++ b/typing/debug_message.ml
@@ -0,0 +1,1068 @@
+open Format
+open Printtyp
+open Parsetree
+open Syntaxerr (* for language_t, language *)
+
+let ppf = std_formatter
+
+let nth n = match n with
+    1 -> "1st"
+  | 2 -> "2nd"
+  | 3 -> "3rd"
+  | _ -> string_of_int n ^ "th"
+
+let print_loc loc =
+  Location.print ppf loc
+
+let rec string_of_longident t = match t with
+    Longident.Lident (l) -> l
+  | Longident.Ldot (t, l) -> (string_of_longident t) ^ "." ^ l
+  | _ -> assert false;;
+
+let print_initial_message () =
+  match language with
+| English -> fprintf ppf
+    "@[The above type error was raised.  Type debugger started.@]@.@."
+| Japanese -> fprintf ppf
+    "@[上記の型エラーが起こりました。デバッガを起動します。@]@.@."
+
+let print_prompt () =
+  fprintf ppf "@[(y/n/q) > @]@?"
+
+let print_ask_env st typ =
+  Printtyp.reset_and_mark_loops typ;
+  match language with
+| English -> fprintf ppf
+    "@[In this scope, do you intend '%s' to be of type:@ %a ?@]@."
+    st Printtyp.type_expr typ
+| Japanese -> fprintf ppf
+    "@[ハイライトされた部分のスコープで %s を@ %a@ 型だと意図していますか？@]@."
+    st Printtyp.type_expr typ
+
+let print_ask_expr typ =
+  Printtyp.reset_and_mark_loops typ;
+  match language with
+| English -> fprintf ppf
+    "@[Do you intend this expression to be of type:@ %a ?@]@."
+    Printtyp.type_expr typ
+| Japanese -> fprintf ppf
+    "@[ハイライトされた部分の型を@ %a@ だと意図していますか？@]@."
+    Printtyp.type_expr typ
+
+let print_identified () =
+  match language with
+| English -> fprintf ppf
+    "@[The source of the type error is highlighted.@]@."
+| Japanese -> fprintf ppf
+    "@[ハイライトされた部分に特定されました。@]@."
+
+let check_duplicate typ1 typ2 =
+  (* type_expr を Ident.t list にする *)
+  (* idents_of_typexp : type_expr -> Ident.t list *)
+  let rec idents_of_typexp {Types.desc = desc} =
+    match desc with
+      Types.Tconstr (path, tyl, _) ->
+       let rec get_id p = match p with
+           Path.Pident (id) -> [id] (* path の情報がある *)
+         | Path.Pdot (p, _, _) -> get_id p
+         | Path.Papply (p1, p2) -> (get_id p1) @ (get_id p2) in
+       List.fold_left (fun il ty -> il @ idents_of_typexp ty) (get_id path) tyl
+    | Types.Tlink (ty) -> idents_of_typexp ty
+    | Types.Tsubst (ty) -> idents_of_typexp ty
+    | Types.Tarrow (_, ty1, ty2, _) ->
+       (idents_of_typexp ty1) @ (idents_of_typexp ty2)
+    | Types.Ttuple (tyl) ->
+       List.fold_left (fun il ty -> il @ idents_of_typexp ty) [] tyl
+    | Types.Tvar _ | Types.Tobject _
+    | Types.Tfield _ | Types.Tnil | Types.Tvariant _ | Types.Tunivar _
+    | Types.Tpoly _ | Types.Tpackage _ -> [] in
+  let is_duplicate i1 i2 =
+    (* equal = true,  same = true  : 同一の型 *)
+    (* equal = true,  same = false : 同じ名前だが別の型 *)
+    (* equal = false, same = false : 全く異なる型 *)
+    if (Ident.equal i1 i2) <> (Ident.same i1 i2) then
+      fprintf ppf "@[（%s が二重に定義されています。）@]@." (Ident.name i1) in
+  let print_duplicate typ1 typ2 =
+    let idl1 = idents_of_typexp typ1 in
+    let idl2 = idents_of_typexp typ2 in
+    try List.iter2 is_duplicate idl1 idl2 with
+      Invalid_argument _ -> () in
+  print_duplicate typ1 typ2
+
+(*** print error massage ***)
+(*
+
+特定される構文ごとに分類
+・式
+<Pexp_ifthenelse>
+  Error12 -- Error15
+<Pexp_apply>
+  Error17 -- Error19, Error27 -- Error28
+<Pexp_function><Pexp_fun>
+  Error20
+<Pexp_match>
+  Error21 -- Error24, Error33
+<Pexp_try>
+  Error53 -- Error55
+<Pexp_construct>
+  Error25, Error56, print_duplicate_name (共通)
+<Pexp_record>
+  Error34 -- Error35, Error51 -- Error52, Error56, print_duplicate_name (共通)
+
+<Pexp_constraint>
+  Error36
+
+<Pexp_array>
+  Error38
+・パターン変数
+Error30
+Error39
+Error40
+
+  print_recursive as
+  Error1  : 再帰関数の定義と呼び出しで型が合わない
+  print_patexps as
+  Error2  : パターンと式の型が合わない
+  (print_patexps2 as Error3)
+  print_welltyped_expr as
+  Error4  : 式の型がプログラマの意図と異なる
+  print_welltyped_env1 as
+  Error5  : 環境の変数のうち一つが別の型として使われている
+  print_welltyped_env_many as
+  Error6  : 環境の変数のうち複数が別の型として使われている
+  (print_welltyped_if_bool as Error7)
+  (print_welltyped_if_unit as Error8)
+  (print_welltyped_if_then_else as Error9)
+  (print_welltyped_match_pattern as Error10)
+  (print_welltyped_match_expression as Error11)
+  print_illtyped_if_predicate as
+  Error12 : 条件部分が bool 型でない
+  print_illtyped_if_then as
+  Error13 : else 部分がない
+  print_illtyped_if_fv as
+  Error14 : if 文の中で同じ変数が別の型として扱われている
+  print_illtyped_if_then_else as
+  Error15 : then 部分と else 部分で型が異なる
+  (print_illtyped_apply as Error16)
+  print_illtyped_apply_funname as
+  Error17 : 関数呼び出しの引数の型が合わない
+  (print_illtyped_apply_beginning as Error18)
+  (print_illtyped_apply_beginning2 as Error19)
+  print_illtyped_function as
+  Error20 : function 文の型エラー
+  print_illtyped_match_exp as
+  Error21 : パターンと match する式の型が異なる
+  print_illtyped_match_left as
+  Error22 : match 文のパターンに複数の型が混在している
+  print_illtyped_match_right as
+  Error23 : match 文の結果に複数の型が混在している
+  (print_illtyped_match_fv as Error24)
+  print_illtyped_constructor as
+  Error25 : コンストラクタのエラー
+  print_illtyped_other as
+  Error26 : デフォルトケース
+  print_illtyped_too_much_args as
+  Error27 : 関数に渡す引数が多い
+  print_illtyped_apply_not_function as
+  Error28 : 関数部分が関数でない
+  print_illtyped_var_undefined as
+  Error29 : 変数が未定義、もしくはstructure_item における区切りがない
+  print_pattern as
+  Error30 : パターンのエラー
+  print_guard as
+  Error32 : ガードのエラー
+  (print_guard_env as Error33)
+  print_illtyped_match_right2 as
+  Error33 : match 文の中で同じ変数が別の型として扱われている
+  print_illtyped_record as
+  Error34 : レコード内の要素の型が定義と異なる
+  print_label_mul as
+  Error35 : レコード内であるフィールドが複数回現れている
+  print_illtyped_constraint as
+  Error36 : (expr : core_type) の左右で型が一致しない
+  print_no_method_use as
+  Error37 : #use の前に区切りがない
+  print_illtyped_array as
+  Error38 : 配列のエラー
+
+  Error41 : let文のエラー(nonrec)
+  Error42 : let文のエラー(rec 1)
+  Error43 : let文のエラー(rec many)
+
+  print_label_mismatch as
+  Error51 : 複数のレコードに定義されたフィールドが混在している
+  print_label_missing as
+  Error52 : 使われていないフィールドがある
+  print_illtyped_try_right as
+  Error53 : try 文の結果に複数の型が混在している
+  print_illtyped_try_left as
+  Error54 : try 文のパターンに複数の型が混在している
+  print_illtyped_try_env as
+  Error55 : try 文の中で同じ変数が別の型として扱われている
+  print_wrong_name as
+  Error56 : 未定義のコンストラクタ/フィールドが存在する
+
+↓並べ替えるなら↓
+・デフォルトケース
+・未定義
+・welltyped のやつ
+・関数適用
+・fun文、function文
+・if文
+・パターンマッチ
+・try文
+・パターン
+・ガード
+・再帰
+・コンストラクタ
+・コンストラクタ/レコード共通
+・レコード
+・#use、constraint、配列
+
+
+*)
+
+let print_recursive typ st typ' =
+  Printtyp.reset_and_mark_loops typ;
+  Printtyp.reset_and_mark_loops typ';
+  match language with
+| English -> fprintf ppf
+    "@[Error1 : The function %s has type@ %a,\
+     @ but '%s' is used at type@ %a in this recursive call.@]@."
+    st Printtyp.type_expr typ st Printtyp.type_expr typ'
+| Japanese -> fprintf ppf
+    "@[Error1 : 関数 %s は@ %a@ 型ですが、@,\
+     再帰呼び出しで %s を %a@ 型として使っています。@,\
+     （再帰呼び出し時の引数の数や型は合っていますか？）@]@."
+    st Printtyp.type_expr typ st Printtyp.type_expr typ'
+
+let print_patexps typ =
+  Printtyp.reset_and_mark_loops typ;
+  match language with
+| English -> fprintf ppf
+    "@[Error2 : This expression has type:@ %a,\
+     @ but it conflicts with the type of the pattern.@]@."
+    Printtyp.type_expr typ
+| Japanese -> fprintf ppf
+    "@[Error2 : この式は@ %a@ 型で、@,\
+     期待されるパターンの型と合いません。@]@."
+    Printtyp.type_expr typ
+
+let print_patexps2 () =
+ (* Printtyp.reset_and_mark_loops pattyp;*)
+  match language with
+| English -> fprintf ppf
+    "@[Error3 : This expression has constant type,@,\
+     but it conflicts with the type of the pattern.@]@."
+| Japanese -> fprintf ppf
+    "@[Error3 : この式は定数になっていますが、@,\
+     let 文で束縛する式は変数もしくはパターンでなければなりません。@]@."
+
+let print_welltyped_expr typ =
+  Printtyp.reset_and_mark_loops typ;
+  match language with
+| English -> fprintf ppf
+    "@[Error4 : This expression has type@ %a.@]@."
+    Printtyp.type_expr typ
+| Japanese -> fprintf ppf
+    "@[Error4 : この式の型は@ %a@ 型です。@]@."
+    Printtyp.type_expr typ
+
+let print_welltyped_env1 st typ =
+  Printtyp.reset_and_mark_loops typ;
+  match language with
+| English -> fprintf ppf
+    "@[Error5 : The variable '%s' is used as an expression of type:@ %a.@]@."
+    st Printtyp.type_expr typ
+| Japanese -> fprintf ppf
+    "@[Error5 : 変数 %s は@ %a@ 型として使われています。@]@."
+    st Printtyp.type_expr typ
+
+let print_welltyped_env_many st typ rest =
+  Printtyp.reset_and_mark_loops typ;
+  begin match language with
+| English -> fprintf ppf
+    "@[Error6 : Following variables are used as expressions of types:@]@."
+| Japanese -> fprintf ppf
+    "@[Error6 : 次の変数は示される型として使われています。@]@."
+  end;
+  fprintf ppf "  @[%s : %a" st Printtyp.type_expr typ;
+  List.iter (fun (((st, _), _, _), typ) ->
+              (* Printtyp.reset_and_mark_loops typ; *)
+              fprintf ppf ",@ %s : %a" st Printtyp.type_expr typ)
+            rest;
+  fprintf ppf "@]@."
+
+let print_welltyped_if_bool st typ rest =
+  Printtyp.reset_and_mark_loops typ;
+  begin match language with
+| English -> fprintf ppf
+    "Error7 : Expressions at the following variables need the following types.\
+     @. The predicate of a conditional expression needs to have type bool.@."
+| Japanese -> fprintf ppf
+    "Error7 : 次の変数が示される型になっています。@,\
+     if 文の条件部は bool 型でなければなりません。@."
+  end;
+  fprintf ppf "  @[%s : %a" st Printtyp.type_expr typ;
+  List.iter (fun (((st, _), _, _), typ) ->
+              (* Printtyp.reset_and_mark_loops typ; *)
+              fprintf ppf ",@ %s : %a" st Printtyp.type_expr typ)
+            rest;
+  fprintf ppf "@]@."
+
+let print_welltyped_if_unit st typ rest =
+  Printtyp.reset_and_mark_loops typ;
+  begin match language with
+| English -> fprintf ppf
+    "Error8 : Expressions at the following variables need the following types.\
+     @. Since the conditional expression does not have else branch,@,\
+     then branch needs to have type unit.@. (or you might forgot else branch)@."
+| Japanese -> fprintf ppf
+    "Error8 : 次の変数が示される型になっています。@,\
+     else 部分がないため if 文の then 部分は unit 型でなければなりません。@,\
+     （もしくは else 部分を忘れていませんか？）@."
+  end;
+  fprintf ppf "  @[%s : %a" st Printtyp.type_expr typ;
+  List.iter (fun (((st, _), _, _), typ) ->
+              (* Printtyp.reset_and_mark_loops typ; *)
+              fprintf ppf ",@ %s : %a" st Printtyp.type_expr typ)
+            rest;
+  fprintf ppf "@]@."
+
+let print_welltyped_if_then_else st typ rest =
+  Printtyp.reset_and_mark_loops typ;
+  begin match language with
+| English -> fprintf ppf
+    "Error9 : Expressions at the following variables need the following types.\
+     @. Then branch and else branch of a conditional expression need to be \
+     the same type.@."
+| Japanese -> fprintf ppf
+    "Error9 : 次の変数が示される型になっています。@,\
+     if 文の then 部分と else 部分は同じ型でなければなりません。@."
+  end;
+  fprintf ppf "  @[%s : %a" st Printtyp.type_expr typ;
+  List.iter (fun (((st, _), _, _), typ) ->
+              (* Printtyp.reset_and_mark_loops typ; *)
+              fprintf ppf ",@ %s : %a" st Printtyp.type_expr typ)
+            rest;
+  fprintf ppf "@]@."
+
+(* TODO : English messages *)
+let print_welltyped_match_pattern st typ rest =
+  Printtyp.reset_and_mark_loops typ;
+  begin match language with
+| English -> fprintf ppf
+    "Error10 : Expressions at the following variables need the following types:\
+     @."
+| Japanese -> fprintf ppf
+    "Error10 : 次の変数が示される型になっています。@,\
+     match 文の矢印の左側は同じ型でなければなりません。@."
+  end;
+  fprintf ppf "  @[%s : %a" st Printtyp.type_expr typ;
+  List.iter (fun (((st, _), _, _), typ) ->
+              (* Printtyp.reset_and_mark_loops typ; *)
+              fprintf ppf ",@ %s : %a" st Printtyp.type_expr typ)
+            rest;
+  fprintf ppf "@]@."
+
+let print_welltyped_match_expression st typ rest =
+  Printtyp.reset_and_mark_loops typ;
+  begin match language with
+| English -> fprintf ppf
+    "Error11 : Expressions at the following variables need the following types:\
+     @."
+| Japanese -> fprintf ppf
+    "Error11 : 次の変数が示される型になっています。@,\
+     match 文の矢印の右側は同じ型でなければなりません。@."
+  end;
+  fprintf ppf "  @[%s : %a" st Printtyp.type_expr typ;
+  List.iter (fun (((st, _), _, _), typ) ->
+              (* Printtyp.reset_and_mark_loops typ; *)
+              fprintf ppf ",@ %s : %a" st Printtyp.type_expr typ)
+            rest;
+  fprintf ppf "@]@."
+
+let print_illtyped_var_undefined () =
+  match language with
+| English -> fprintf ppf
+    "@[Error29 : This variable is undefined.@]@."
+| Japanese -> fprintf ppf
+    "@[Error29 : この変数は未定義です。@]@."
+
+let print_illtyped_if_predicate typ =
+  Printtyp.reset_and_mark_loops typ;
+  match language with
+| English -> fprintf ppf
+    "@[Error12 : The type of the predicate part is:@ %a,@,\
+     but it has to be bool.]@."
+    Printtyp.type_expr typ
+| Japanese -> fprintf ppf
+    "@[Error12 : 条件部分の型は@ %a@ ですが bool 型でなくてはなりません。@]@."
+    Printtyp.type_expr typ
+
+let print_illtyped_if_then typ =
+  Printtyp.reset_and_mark_loops typ;
+  begin match language with
+| English -> fprintf ppf
+    "@[Error13 : The type of the then branch is:@ %a,@,\
+     but it has to be unit.]@."
+    Printtyp.type_expr typ
+| Japanese -> fprintf ppf
+    "@[Error13 : then 部分が@ %a @ 型になっていますが@ \
+     else 部分がないため unit 型でなくてはなりません。@]@."
+    Printtyp.type_expr typ
+  end;
+  begin match language with
+| English -> fprintf ppf
+    "@[(Or, you forgot the else branch perhaps?)@]@."
+| Japanese -> fprintf ppf
+    "@[（もしくは else 部分を書き忘れていませんか？）@]@."
+  end
+
+let print_illtyped_if_fv () =
+  match language with
+| English -> fprintf ppf
+    "@[Error14 : Some variables are used at different types.@]@."
+| Japanese -> fprintf ppf
+    "@[Error14 : 同じ変数が別の場所で別の型として使われています。@]@."
+
+let print_illtyped_if_then_else typ2 typ3 =
+  Printtyp.reset_and_mark_loops typ2;
+  Printtyp.reset_and_mark_loops typ3;
+  begin match language with
+| English -> fprintf ppf
+    "@[Error15 : The types of the then and else branches are:@ %a@ and@ %a,@,\
+     but they have to be the same.@,\
+     (Or, some variables are used at different types.)@]@."
+    Printtyp.type_expr typ2 Printtyp.type_expr typ3
+| Japanese -> fprintf ppf
+    "@[Error15 : then 部分が@ %a@ 型で else 部分が@ %a@ 型になっていますが、@,\
+     これらは同じ型でなくてはなりません。@,\
+     （または同じ変数が別の場所で別の型として使われています。）@]@."
+    Printtyp.type_expr typ2 Printtyp.type_expr typ3
+  end;
+  check_duplicate typ2 typ3
+
+let rec print_illtyped_apply_args typs n = match typs with
+    [] -> ()
+  | typ :: rest ->
+      begin match language with
+      | English -> fprintf ppf
+          " @[<2>%s argument :@ %a@]@." (nth n) Printtyp.type_expr typ
+      | Japanese -> fprintf ppf
+          " @[<2>%d 番目の引数の型：@,%a@]@." n Printtyp.type_expr typ
+      end;
+      print_illtyped_apply_args rest (n + 1)
+
+(* 関数名なし *)
+let print_illtyped_apply n exp_typ typs well_typ =
+  match language with
+| English ->
+    fprintf ppf
+      "@[Error16 : The type conflict occurs at the %s argument.@,\
+       The types of function and arguments, required type of %s argument are:@]"
+      (nth n) (nth n);
+    fprintf ppf
+      "@[Function :@ %a@]@."
+      Printtyp.type_expr exp_typ;
+    print_illtyped_apply_args typs 1;
+    fprintf ppf
+      " @[Required type of %s argument :@ %a@.@]"
+      (nth n) Printtyp.type_expr well_typ
+| Japanese ->
+    fprintf ppf
+      "@[Error16 : この関数呼び出しの %d 番目の引数で型が合いません。@,\
+       関数、引数、%d 番目の引数に要求される型は以下の通りです。@]@."
+      n n;
+    fprintf ppf
+      "@[関数部分：@,%a@]@."
+      Printtyp.type_expr exp_typ;
+    print_illtyped_apply_args typs 1;
+    fprintf ppf
+      " @[%d 番目の引数に要求される型：@,%a@.@]"
+      n Printtyp.type_expr well_typ
+
+(* 関数名あり *)
+let print_illtyped_apply_funname n exp_typ exps typs well_typ name =
+  match language with
+| English ->
+    fprintf ppf
+      "@[Error17 : The type conflict occurs at the %s argument.@,\
+       The types of function and %s argument, required type of %s argument are:@]"
+      (nth n) (nth n) (nth n);
+    fprintf ppf
+      "@[Function %a :@ %a@]@."
+      Pprintast.expression name
+      Printtyp.type_expr exp_typ;
+    fprintf ppf
+      " @[<2>%s argument :@ %a@]@."
+      (nth n) Printtyp.type_expr (List.nth typs (n - 1));
+    fprintf ppf
+      " @[Required type of %s argument :@ %a@.@]"
+      (nth n) Printtyp.type_expr well_typ
+| Japanese -> fprintf ppf
+    "@[Error17 : この関数呼び出しの %d 番目の引数で型が合いません。@,\
+     関数、%d 番目の引数、%d 番目の引数に要求される型は以下の通りです。@]@." n n n;
+    fprintf ppf
+      "@[関数部分 %a：@,%a@]@."
+      Pprintast.expression name
+      Printtyp.type_expr exp_typ;
+    fprintf ppf
+      " @[<2>%d 番目の引数 %a：@,%a@]@."
+      n Pprintast.expression (List.nth exps (n - 1)) Printtyp.type_expr (List.nth typs (n - 1));
+    fprintf ppf
+      " @[%d 番目の引数に要求される型：@,%a@.@]"
+      n Printtyp.type_expr well_typ;
+    check_duplicate (List.nth typs (n - 1)) well_typ
+
+(*
+let print_illtyped_apply_funname n exp_typ typs well_typ name =
+  match language with
+| English ->
+    fprintf ppf
+      "@[Error17 : The type conflict occurs at the %s argument.@,\
+       The types of function and arguments, required type of %s argument are:@]"
+      (nth n) (nth n);
+    fprintf ppf
+      "@[Function %a :@ %a@]@."
+      Pprintast.expression name
+      Printtyp.type_expr exp_typ;
+    print_illtyped_apply_args typs 1;
+    fprintf ppf
+      " @[Required type of %s argument :@ %a@.@]"
+      (nth n) Printtyp.type_expr well_typ
+| Japanese -> fprintf ppf
+    "@[Error17 : この関数呼び出しの %d 番目の引数で型が合いません。@,\
+     関数、引数、%d 番目の引数に要求される型は以下の通りです。@]@." n n;
+    fprintf ppf
+      "@[関数部分 %a：@,%a@]@."
+      Pprintast.expression name
+      Printtyp.type_expr exp_typ;
+    print_illtyped_apply_args typs 1;
+    fprintf ppf
+      " @[%d 番目の引数に要求される型：@,%a@.@]"
+      n Printtyp.type_expr well_typ;
+    check_duplicate (List.nth typs (n - 1)) well_typ
+    *)
+
+let rec print_funtypes n funtypes =
+  match language with
+| English ->
+    begin match funtypes with
+        [] -> fprintf ppf
+          "@[(some arguments might be missing.)@]@."
+      | (m, typ) :: rest ->
+          fprintf ppf
+            " @[Type of %s argument :@ %a@]@."
+            (nth m) Printtyp.type_expr typ;
+          print_funtypes n rest
+    end
+| Japanese ->
+    begin match funtypes with
+        [] -> fprintf ppf
+          "@[これらに引数を渡すのを忘れていませんか？@]@."
+      | (m, typ) :: rest ->
+          fprintf ppf
+            " @[%d 番目の引数の型：@,%a@]@."
+            m Printtyp.type_expr typ;
+          print_funtypes n rest
+    end
+
+let print_illtyped_apply_beginning n name exp_typ typs funtype_args =
+  match language with
+| English ->
+    fprintf ppf
+      "@[Error18 : The type conflict occurs at the %s argument.@]@."
+      (nth n);
+    fprintf ppf
+      "@[Function %a :@ %a@]@."
+      Pprintast.expression name
+      Printtyp.type_expr exp_typ;
+    print_illtyped_apply_args typs 1;
+    fprintf ppf
+      "@[The following arguments have function type.@]@.";
+      print_funtypes n funtype_args
+| Japanese ->
+    fprintf ppf
+      "@[Error18 : この関数呼び出しの %d 番目の引数で型が合いません。@]@."
+      n;
+    fprintf ppf
+      "@[関数部分 %a の型：@,%a@]@."
+      Pprintast.expression name
+      Printtyp.type_expr exp_typ;
+    print_illtyped_apply_args typs 1;
+    fprintf ppf "@[以下の引数が関数型になっています。@]@.";
+      print_funtypes n funtype_args
+
+(* 関数型になっている引数がないとき *)
+let print_illtyped_apply_beginning2 = print_illtyped_apply_funname
+(*
+let print_illtyped_apply_beginning2 n name exp_typ n_typ =
+  match language with
+| English ->
+    fprintf ppf
+      "@[Error19 : The type conflict occurs at the %s argument.@]@."
+      (nth n);
+| Japanese ->
+    fprintf ppf
+      "@[Error19 : この関数呼び出しの %d 番目の引数で型が合いません。@]@."
+      n;
+    fprintf ppf
+      "@[関数部分 %a の型：@,%a@]@."
+      Pprintast.expression name
+      Printtyp.type_expr exp_typ;
+    fprintf ppf
+      " @[%d 番目の引数の型：@,%a@.@]@."
+      n Printtyp.type_expr n_typ
+ *)
+
+let print_illtyped_function () =
+  match language with
+| English -> fprintf ppf
+    "@[Error20 : The pattern forces some variable an unintended type.@]@."
+| Japanese -> fprintf ppf
+    "@[Error20 : パターンによって変数の型が意図しないものに\
+     強制されています。@]@."
+
+let print_illtyped_match () =
+  match language with
+| English -> fprintf ppf
+    "@[Somewhere in this match expression is wrong.@]@."
+| Japanese -> fprintf ppf
+    "@[この match 文のどこかがおかしいです。@]@."
+
+let print_illtyped_match_exp typ1 typ2 =
+  match language with
+| English -> fprintf ppf
+    "@[Error21 : Somewhere in this match expression is wrong.@]@." (* 英語 *)
+| Japanese -> fprintf ppf
+    "@[Error21 : match する式が@ %a@ 型でパターンが@ %a@ 型になっていますが、\
+     @,これらは同じ型でなくてはなりません。@]@."
+    Printtyp.type_expr typ1 Printtyp.type_expr typ2;
+              check_duplicate typ1 typ2
+
+let print_illtyped_match_left typ1 typ2 =
+  match language with
+| English -> fprintf ppf
+    "@[Error22 : Somewhere in this match expression is wrong.@]@." (* 英語 *)
+| Japanese -> fprintf ppf
+    "@[Error22 : ハイライト部分が@ %a@ 型でそれ以前までの矢印の左側が\
+     @ %a@ 型になっていますが、@,これらは同じ型でなくてはなりません。@]@."
+    Printtyp.type_expr typ1 Printtyp.type_expr typ2;
+              check_duplicate typ1 typ2
+
+let print_illtyped_match_right typ1 typ2 =
+  match language with
+| English -> fprintf ppf
+    "@[Error23 : The type of this expression is:@ %a,@,\
+     but the type of the preceeding clause is:@ %a.@,\
+     They must be the same type.@]@."
+    Printtyp.type_expr typ1 Printtyp.type_expr typ2
+| Japanese -> fprintf ppf
+    "@[Error23 : ハイライト部分が@ %a@ 型でそれ以前までの矢印の右側が\
+     @ %a@ 型になっていますが、@,これらは同じ型でなくてはなりません。@]@."
+    Printtyp.type_expr typ1 Printtyp.type_expr typ2;
+              check_duplicate typ1 typ2
+
+let print_illtyped_match_right2 () =
+  match language with
+| English -> fprintf ppf
+    "@[Error33 : Some variables in this expression is used at different type@ \
+     at different place.@]@."
+| Japanese -> fprintf ppf
+    "@[Error33 : ハイライト部分の変数が\
+     別の場所で別の型として使われています。@]@."
+
+let print_illtyped_match_fv () =
+  match language with
+| English -> fprintf ppf
+    "@[Error24 : Some variables are used at different types.@]@."
+| Japanese -> fprintf ppf
+    "@[Error24 : 同じ変数が別の場所で別の型として使われています。@]@."
+
+let rec print_type lid plst args =
+    match plst with
+    | [] ->
+       begin
+         if Longident.last lid = "::"
+         then
+           begin
+             match args with
+             | [Some (e1, t1); Some (e2, t2)] -> print_list_clash e1 t1 e2 t2
+             | [_; Some (_, typ)] -> print_list_mismatch typ
+             | _ -> ()
+           end
+         else
+           begin
+             print_constructor_name "'a option" lid;
+             if Longident.last lid = "Some"
+             then print_no_args "Some"
+             else print_arity_mismatch (List.length args) 0
+           end
+       end
+    | (name, vs) :: rest ->
+       try
+         print_args lid (name, vs) args
+       with
+         Not_found -> print_type lid rest args
+
+and print_args lid (name, vlst) args =
+  match vlst with
+  | [] -> raise Not_found
+  | (value, cts) :: rest ->
+     let a_sum = List.length args and c_sum = List.length cts in
+     let rec num t = match t with
+         [] -> 0
+       | first :: rest ->
+          if first = None
+          then num rest
+          else a_sum - (List.length rest) in
+     let n = num args in
+     if value <> string_of_longident lid
+     then
+       (* コンストラクタ名が一致しない場合は次へ進む *)
+       print_args lid (name, rest) args
+     else
+       begin
+         (* 該当するコンストラクタ名を表示 *)
+         print_constructor_name name lid;
+         if a_sum = 0
+         then
+           (* 引数が見つからない *)
+           print_no_args (string_of_longident lid)
+         else
+           begin
+             if a_sum = c_sum
+             then
+               (* 引数の数が同じ *)
+               let (en, tn) = match (List.nth args (n - 1)) with
+                 | Some (e, t) -> (e, t)
+                 | _ -> assert false in
+               begin
+                 print_arg_type_clash n (en, tn) (List.nth cts (n - 1));
+                 print_constuctor_type lid cts
+               end
+             else
+               (* 引数の数が異なる *)
+               print_arity_mismatch a_sum c_sum
+           end
+       end
+
+and print_list_clash e1 t1 e2 t2 =
+  fprintf ppf
+          "@[ハイライト部分のリストで、先頭の要素と末尾のリストの型が合いません。@ \
+           先頭の要素、末尾のリストは以下の通りです。@]@.";
+  fprintf ppf
+          " @[　先頭の要素 %a：@,%a @]@."
+          Pprintast.expression e1 Printtyp.type_expr t1;
+  fprintf ppf
+          " @[末尾のリスト %a：@,%a @]@."
+          Pprintast.expression e2 Printtyp.type_expr t2
+
+and print_list_mismatch typ =
+  fprintf ppf
+          "@[ハイライト部分の末尾が %a 型になっていますが、@ \
+           :: の右側はリストでなければなりません。@]@."
+          Printtyp.type_expr typ
+and print_constructor_name tname lid =
+  match lid with
+  | Longident.Ldot (t, l) ->
+     fprintf ppf
+             "@[ハイライトされた部分では、モジュール %s の中に定義された %s 型のコンストラクタ %s の、" (string_of_longident t) tname l
+  | _ ->
+     fprintf ppf
+             "@[%s 型のコンストラクタ %s の" tname (string_of_longident lid)
+
+and print_arg_type_clash n (e, t) c =
+  (* 引数の数が同じ *)
+  fprintf ppf
+          "%d 番目の引数で型が合いません。@ \
+           %d 番目の引数、%d 番目の引数に要求される型、コンストラクタの定義は以下の通りです。@]@."
+          n n n;
+  fprintf ppf
+          " @[<2>%d 番目の引数 %a：@,%a@]@."
+          n Pprintast.expression e Printtyp.type_expr t;
+  fprintf ppf
+          " @[<2>%d 番目の引数に要求される型：@,%a@.@]"
+          n Pprintast.core_type c;
+and print_constuctor_type lid cts =
+      fprintf ppf
+      " @[コンストラクタの定義：@,%s " (string_of_longident lid);
+     let rec print_core ct = match ct with
+         [] -> ()
+       | [first] ->
+          (* 引数が一つしかない場合 *)
+          fprintf ppf "%a" Pprintast.core_type first
+       | first :: rest ->
+          fprintf ppf "%a * " Pprintast.core_type first;
+          print_core rest in
+     if cts <> []
+     then (fprintf ppf "of ";  print_core cts);
+     fprintf ppf "@]@."
+
+and print_arity_mismatch n m =
+  (* 引数の数が異なる *)
+  fprintf ppf
+          "引数の数が違います。@ \
+           ハイライトされた部分では %d 個になっていますが、定義では %d 個です。@]@." n m
+and print_no_args l =
+  (* 引数が見つからない *)
+  fprintf ppf
+          "引数が見つかりません。@ \
+           （もしくは、 (%s ...) のようにかっこをつけましょう。）@]@." l
+
+let print_illtyped_constructor lid plst args =
+  match language with
+| English -> fprintf ppf
+    "@[Error25 : The constructor is given a wrong type of argument(s).@]@."
+| Japanese ->
+   fprintf ppf
+    "@[Error25 : コンストラクタの引数の型が合っていません。@]@.";
+   print_type lid plst args
+
+let print_illtyped_other () =
+  match language with
+| English -> fprintf ppf
+    "@[Error26 : This expression is ill-typed.@]@."
+| Japanese -> fprintf ppf
+    "@[Error26 : この部分に型がつきません。@]@."
+
+let print_illtyped_too_much_args n exp_typ typs name =
+  match language with
+| English ->
+    fprintf ppf
+      "@[The type conflict occurs at the %s argument.@]@."
+      (nth n)
+| Japanese ->
+    fprintf ppf
+      "@[Error27 : この関数呼び出しで渡されている引数が多いようです。@,\
+       関数と引数の型は以下の通りです。@]@.";
+    fprintf ppf
+      "@[関数部分 %a：@,%a@]@."
+      Pprintast.expression name
+      Printtyp.type_expr exp_typ;
+    print_illtyped_apply_args typs 1
+
+let print_illtyped_apply_not_function exp =
+  match language with
+| English -> fprintf ppf
+    "@[Error28 : This is not a function@]@.";
+| Japanese ->
+    fprintf ppf
+      "@[Error28 : ハイライトされた部分が関数呼び出しになっているのに、@,\
+       関数部分が@ %a@ 型になっています。@]@."
+       Printtyp.type_expr exp
+
+(* Error29 is already defined above *)
+
+let print_pattern () =
+  match language with
+| English -> fprintf ppf
+    "@[Error30 : This pattern is ill-formed.@]@."
+| Japanese -> fprintf ppf
+    "@[Error30 : ハイライトされたパターンに型がつきません@]@."
+
+let print_guard typ =
+  Printtyp.reset_and_mark_loops typ;
+  match language with
+| English -> fprintf ppf
+    "@[Error31 : The type of this expression is:@ %a,@,\
+     but it has to be bool.@]@."
+    Printtyp.type_expr typ
+| Japanese -> fprintf ppf
+    "@[Error31 : ハイライトされた部分の型は@ %a@ ですが@ \
+     bool 型でなくてはなりません。@]@."
+    Printtyp.type_expr typ
+
+let print_guard_env () =
+  match language with
+| English -> fprintf ppf
+    "@[Error32 : A variable in this expression is used at different type@ \
+     at different place.@]@."
+| Japanese -> fprintf ppf
+    "@[Error32 : この式の中の変数が、別のところで別の型で使われています。@]@."
+
+(* Error33 is already defined above *)
+
+let print_illtyped_record typ fields =
+  (* 式が □ でないフィールドの情報だけを取る *)
+  List.iter (
+      fun ((f, ft), (e, et)) ->
+      if e <> Debug_core.dummy_assertfalse e
+      then
+        begin
+          fprintf ppf
+                  "@[Error34 : レコード %a のフィールド %s の型が合っていません。@ \
+                   ハイライト部分、定義上の型は以下の通りです。@]@."
+                  type_expr typ (Longident.last f);
+          fprintf ppf
+                  "@[ハイライト部分：@,(%a : %a)@]@."
+                  Pprintast.expression e type_expr et;
+          fprintf ppf
+                  "    @[定義上の型：@,%a@.@]"
+                  Pprintast.core_type ft.pld_type
+        end
+    ) fields
+
+let print_label_mul fname =
+  match language with
+| English -> fprintf ppf
+    "@[Error35 : The record field label %s@ is defined several times.@]@." fname
+| Japanese -> fprintf ppf
+    "@[Error35 : ハイライトされた部分で、レコードのフィールド %s が複数回使われています。@ \
+     (レコードのフィールド名はすべて異なる必要があります。)@]@." fname
+
+let print_illtyped_constraint typ1 typ2 =
+  Format.fprintf ppf
+    "@[Error36 : ハイライトされた部分で、: の左側の式は %a 型ですが、@ \
+     : の右側の型は %a 型です。これらは同じ型でなくてはなりません。@]@."
+    Printtyp.type_expr typ1 Printtyp.type_expr typ2;
+  check_duplicate typ1 typ2
+
+let print_no_method_use () =
+  Format.fprintf ppf
+    "@[Error37 : #use はファイルの先頭に書きましょう。@]@."
+
+let print_illtyped_array typ1 typ2 =
+  Format.fprintf ppf
+                 "@[Error38 : ハイライトされた部分は %a 型の配列ですが、@ \
+                  %a 型の要素が含まれています。 @ \
+                  配列の各要素の型は、すべて同じである必要があります。@]@."
+                 Printtyp.type_expr typ1 Printtyp.type_expr typ2;
+  check_duplicate typ1 typ2
+
+let print_orpad_vars () =
+  fprintf ppf
+          "@[Error39 : 変数を含むパターンは、| で矢印の左側にまとめることができません。@,\
+           すべてのパターンに式をつけるか、パターンに変数を含まないようにしましょう。@]@."
+
+let print_multiply_bound_variable s =
+  fprintf ppf
+          "@[Error40 : ハイライトされた部分で、パターン変数 %s が多重に定義されています。@,\
+           (ひとつのパターンの中に定義する変数の名前はすべて異なる必要があります。)@]@." s
+
+(* let文のエラー *)
+let print_illtyped_let_rec1 v =
+  fprintf ppf
+          "@[Error41 : ハイライト部分の関数定義 %a に再帰があります。@,\
+           let の後に rec を書きましょう。@]@."
+          Pprintast.pattern v.pvb_pat
+
+let print_illtyped_let_rec_many vs =
+  fprintf ppf
+          "@[Error42 : ハイライト部分の関数定義 ";
+  List.iter (fun v' -> fprintf ppf "%a " Pprintast.pattern v'.pvb_pat) vs;
+  fprintf ppf "@,\
+           に相互再帰があります。let の後に rec を書きましょう。@]@."
+
+let print_illtyped_let v vs =
+  fprintf ppf
+          "@[Error43 : ハイライト部分の関数定義 %a の中で、@,\
+           and で同時に定義された他の関数 "
+          Pprintast.pattern v.pvb_pat;
+  List.iter (fun v' -> fprintf ppf "%a " Pprintast.pattern v'.pvb_pat) vs;
+  fprintf ppf
+          "@,\
+           が1つ以上呼び出されています。in や ;; を使って各定義を独立させましょう。@]@."
+
+let print_illtyped_case exp =
+  fprintf ppf
+          "@[Error44 : ハイライト部分のパターン変数 %a が @,\
+           式中で異なる型として使われています。@]@." Pprintast.expression exp
+
+let print_label_mismatch env lid trace =
+  match language with
+| English -> report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "@[Error51 : The record field %a@ belongs to the type"
+                   longident lid)
+        (function ppf ->
+           fprintf ppf "but is mixed here with fields of type");
+             fprintf ppf "@]@."
+| Japanese -> report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "@[Error51 : フィールド %a@ が属する型は"
+                   longident lid)
+        (function ppf ->
+           fprintf ppf "ですが、それを含む全体のレコード型は");
+              fprintf ppf " です。@]@."
+
+let print_label_missing labels =
+  match language with
+| English ->
+   let print_labels ppf =
+     List.iter (fun lbl -> fprintf ppf "@ %s" (Ident.name lbl)) in
+   fprintf ppf "@[<hov>Some record fields are undefined:%a@]"
+           print_labels labels
+| Japanese ->
+   let print_labels ppf =
+     List.iter (fun lbl -> fprintf ppf " %s" (Ident.name lbl)) in
+   fprintf ppf "@[Error52 : ハイライトされた部分で、レコードのフィールド%a が足りません。@]@." print_labels labels
+
+let print_illtyped_try_right typ1 typ2 =
+  begin match language with
+| English -> fprintf ppf
+    "@[Error53 : Somewhere in this try expression is wrong.@]@." (* 英語 *)
+| Japanese -> fprintf ppf
+    "@[Error53 : try する式が@ %a@ 型で矢印の右側が@ %a@ 型になっていますが、\
+     @,これらは同じ型でなくてはなりません。@]@."
+    Printtyp.type_expr typ1 Printtyp.type_expr typ2
+  end;
+  check_duplicate typ1 typ2
+
+let print_illtyped_try_left typ =
+  match language with
+| English -> fprintf ppf
+    "@[Error54 : Somewhere in this try expression is wrong.@]@." (* 英語 *)
+| Japanese -> fprintf ppf
+    "@[Error54 : try 文のパターンが @ %a@ 型になっていますが、\
+     @,これは例外でなくてはなりません。@]@."
+    Printtyp.type_expr typ
+
+let print_illtyped_try_env () =
+  match language with
+| English -> fprintf ppf
+    "@[Error55 : Some variables in this expression is used at different type@ \
+     at different place.@]@."
+| Japanese -> fprintf ppf
+    "@[Error55 : ハイライト部分の変数が\
+     別の場所で別の型として使われています。@]@."
+
+
+let print_wrong_name kind typ name =
+  match language with
+  | English ->
+     fprintf ppf
+	     "@[Error56 : The %s %s does not belong to type %a.@]@."
+	     (if kind = "record" then "field" else kind) name Printtyp.type_expr typ
+  | Japanese ->
+     fprintf ppf
+	     "@[Error56 : %s %s は %a の中で定義されていません。@]@."
+	     (if kind = "record" then "フィールド" else "コンストラクタ") name Printtyp.type_expr typ
+
+let print_unbound_name kind lid =
+
+  let var_name = Longident.last lid in (* 変数名 *)
+  let mod_names = (* モジュールの名前リスト *)
+    List.filter (fun v -> v <> var_name)
+                (List.rev (Longident.flatten lid)) in
+
+  fprintf ppf
+          "@[Error57 : %s という名前の%sは、%s定義されていません。@]@."
+          var_name
+          (if kind = "record"
+           then "フィールドを持つレコード"
+           else if kind = "module"
+           then "モジュール"
+           else "コンストラクタ")
+          (if mod_names = [] then ""
+           else "モジュール" ^ List.hd mod_names ^ "の中で")
+
+let print_duplicate_name kind name =
+  match language with
+  | English ->
+     fprintf ppf "@[Two constructors are named %s@]@." name
+  | Japanese ->
+     let kind' = (if kind = "record" then "フィールド" else "コンストラクタ") in
+     fprintf ppf "@[Error58 : %s %s が複数あります。@,\
+                  定義する%sの名前は、すべて異なる必要があります。@]@." kind' name kind'
diff --git a/typing/debug_slice.ml b/typing/debug_slice.ml
new file mode 100644
index 0000000..cca18fa
--- /dev/null
+++ b/typing/debug_slice.ml
@@ -0,0 +1,1863 @@
+(* open Misc *)
+(* open Path *)
+open Asttypes
+open Ast_helper
+
+(* open Types *)
+open Typedtree
+(* open Ctype *)
+(* open Format *)
+
+open Parsetree
+
+open Debug_core
+
+
+type expr_cxt = expression -> expression
+type item_cxt = expr_cxt -> expression -> structure
+type structure_cxt = (structure_item * Env.t) list -> structure -> structure
+
+(* go *)
+(* 'a context_t を引数に持つ関数を、最後に 'a 型で受け取る形にする。 *)
+(* かっこを減らせる, 'a 型の引数で再帰する関数に渡すときに便利。 *)
+let go f prefix env cxt x = f ((x, cxt), env, prefix)
+
+
+(* id : 'a -> 'a *)
+let id = fun x -> x
+
+(*
+
+(* map2_... : (expression -> pattern -> expression) -> (expression -> pattern -> pattern) -> 'a -> 'a *)
+(* 引数中に含まれる expression と pattern を書き換えるために使う *)
+let map2_vb fun_exp fun_pat {pvb_pat = p; pvb_expr = e; pvb_attributes = a; pvb_loc = l} =
+  {pvb_pat = fun_pat p e; pvb_expr = fun_exp p e; pvb_attributes = a; pvb_loc = l}
+and map2_case fun_exp fun_pat {pc_lhs = p; pc_guard = g; pc_rhs = e} =
+  {pc_lhs = fun_pat p e; pc_guard = g; pc_rhs = fun_exp p e}
+and map2_le fun_exp _ (l, e) = (l, fun_exp wildcard e)
+(*
+and map2_lp _ fun_pat (l, p) = (l, fun_pat p skeleton')
+ *)
+(* map_... : (expression -> expression) -> (pattern -> pattern) -> 'a -> 'a *)
+(* 1引数関数バージョン *)
+let map_vb fun_exp fun_pat vb =
+  let fun_exp' = fun _ e -> fun_exp e in
+  let fun_pat' = fun p _ -> fun_pat p in
+  map2_vb fun_exp' fun_pat' vb
+and map_case fun_exp fun_pat case =
+  let fun_exp' = fun _ e -> fun_exp e in
+  let fun_pat' = fun p _ -> fun_pat p in
+  map2_case fun_exp' fun_pat' case
+and map_le fun_exp fun_pat le =
+  let fun_exp' = fun _ e -> fun_exp e in
+  let fun_pat' = fun p _ -> fun_pat p in
+  map2_le fun_exp' fun_pat' le
+ *)
+(*
+and map_lp fun_exp fun_pat lp =
+  let fun_exp' = fun _ e -> fun_exp e in
+  let fun_pat' = fun p _ -> fun_pat p in
+  map2_lp fun_exp' fun_pat' lp
+ *)
+(********** pattern slicing **********)
+let rec pattern_variables pat = match pat.ppat_desc with
+    Ppat_any -> []
+  | Ppat_var ({txt = st}) -> [st]
+  | Ppat_alias (p, {txt = st}) -> st :: pattern_variables p
+  | Ppat_constant (_) -> []
+  | Ppat_interval (_, _) -> []
+  | Ppat_tuple (ps) -> List.flatten (List.map pattern_variables ps)
+  | Ppat_construct (_, None) -> []
+  | Ppat_construct (_, Some (p)) -> pattern_variables p
+  | Ppat_variant (_, None) -> []
+  | Ppat_variant (_, Some (p)) -> pattern_variables p
+  | Ppat_record (lps, _) ->
+      List.flatten (List.map (fun (_, p) -> pattern_variables p) lps)
+  | Ppat_array (ps) -> List.flatten (List.map pattern_variables ps)
+  | Ppat_or (p1, p2) -> pattern_variables p1 @ pattern_variables p2
+  | Ppat_constraint (p, _) -> pattern_variables p
+  | Ppat_type (_) -> []
+  | Ppat_lazy (p) -> pattern_variables p
+  | Ppat_unpack ({txt = st}) -> [st]
+  | Ppat_exception (p) -> pattern_variables p
+  | Ppat_extension (_) -> []
+  | Ppat_open (_, p) -> pattern_variables p
+(********** expr_context **********)
+(*
+type expr_context =
+  | Empty
+  | Lambda of pattern * expr_context
+    (* TODO: incorporate labeled arguments, currently ignored *)
+  | Let of rec_flag * value_binding list * expr_context
+let print_cxt cxt = match cxt with
+  | Empty -> "Empty"
+  | Lambda(_) -> "Lambda"
+  | Let(_) -> "Let"
+ *)
+(********** plug **********)
+(*
+(* plug_expr : expression -> expr_context -> expression *)
+let rec plug_expr expr cxt = match cxt with
+  | Empty -> expr
+  | Lambda (pat, c) ->
+      (* パターン変数を全て集め *)
+      let vars = pattern_variables pat in
+      (* 変数名から変数の expression を作る *)
+      let varexp x = Exp.mk (Pexp_ident (mknoloc (Longident.Lident x))) in
+      (* expr と組にして body に入れる。これでパターン変数の型を知る *)
+      (* ダミーの 0 を入れるのは、tuple 長が 2 以上でないとエラーになるため *)
+      let body = Exp.mk (Pexp_tuple
+                          (expr :: dummy_int0 :: List.map varexp vars)) in
+      let exp = Exp.mk (Pexp_fun (Nolabel, None, pat, body)) in
+      plug_expr exp c
+  | Let (flag, bindings, c) ->
+      plug_expr { pexp_desc        = Pexp_let (flag, bindings, expr);
+                  pexp_loc         = Location.none;
+                  pexp_attributes  = [] }
+                c
+
+(* plug_str : (expression * expr_context) -> structure *)
+let plug_str (expr, cxt) =
+  [{ pstr_desc = Pstr_eval (plug_expr expr cxt, []);
+     pstr_loc  = Location.none }]
+ *)
+(********** pattern **********)
+(*
+(* desc_to_desc : pattern_desc -> expression_desc option *)
+let rec desc_to_desc pat = match pat with
+  | Ppat_any ->
+     (* _ *)
+     None
+  | Ppat_var({txt = st; loc = loc'}) ->
+     (* Ppat_var of string loc *)
+     (* x *)
+     Some (Pexp_ident({txt = Longident.Lident(st); loc = loc'}))
+  | Ppat_tuple(ps) ->
+     (* Ppat_tuple of pattern list *)
+     (* (P1, ..., Pn)
+           Invariant: n >= 2
+      *)
+     Some (Pexp_tuple(List.map pat_to_exp ps))
+  | Ppat_constant (c) ->
+     (* 1, 'a', "true", 1.0, 1l, 1L, 1n *)
+     Some (Pexp_constant (c))
+  | Ppat_construct (lid, p) ->
+     (* Ppat_construct of Longident.t loc * pattern option *)
+     (* C                None
+           C P              Some P
+           C (P1, ..., Pn)  Some (Ppat_tuple [P1; ...; Pn])
+      *)
+     Some (Pexp_construct (lid, match p with None -> None | Some p' -> Some (pat_to_exp p')))
+  | Ppat_record (lps, (*flg*)_) ->
+  (* Ppat_record of (Longident.t loc * pattern) list * closed_flag *)
+  (* { l1=P1; ...; ln=Pn }     (flag = Closed)
+           { l1=P1; ...; ln=Pn; _}   (flag = Open)
+
+           Invariant: n > 0
+   *)
+
+
+     Some (Pexp_record (List.map (fun (l, p) -> (l, pat_to_exp p)) lps, None))
+  | Ppat_constraint (p, ct) ->
+     Some (Pexp_constraint (pat_to_exp p, ct))
+  | _ -> None
+
+(* pat_to_exp : pattern -> expression option *)
+and pat_to_exp {ppat_desc = d; ppat_loc = l; ppat_attributes = a} =
+  match desc_to_desc d with
+  | None -> skeleton
+  | Some (d') -> {pexp_desc = d'; pexp_loc = l; pexp_attributes = a}
+ *)
+
+let unconstraint_pat pat cxt = match pattern_variables pat with
+  | [] -> cxt
+  | first :: [] ->
+     Lambda (
+         desc_to_pat (
+             Ppat_var ({txt = first; loc = Location.none})
+           ) pat, cxt)
+  | lst ->
+     Lambda (
+         desc_to_pat (
+             Ppat_tuple (
+                 List.map (
+                     fun s -> desc_to_pat (
+                                  Ppat_var ({txt = s; loc = Location.none})
+                                ) pat
+                   ) lst)
+           ) pat, cxt)
+
+let rec plug_cxt cxt1 cxt2 = match cxt1 with
+  | Empty -> cxt2
+  | Lambda (pat, cxt') -> Lambda(pat, plug_cxt cxt' cxt2)
+  | Let (st, t, cxt') -> Let(st, t, plug_cxt cxt' cxt2)
+
+(********** obtain type and environment of expr **********)
+
+(* type of elements of yes/no list *)
+(* type yes_no_list = (string context_t * type_expr) list *)
+(* yes_no_list という名前を使っているが、ここでは環境として使っている *)
+
+(* collect_one : (string context_t * type_expr) context_t -> string list ->
+                 type_expr -> yes_no_list * type_expr *)
+let collect_one ((vartyps, cxt'), env, prefix) vars typ =
+  match decode_tuple typ with
+      Some (exp_typ :: _ :: typs) -> (* _ は dummy_int0 の型 *)
+        (List.map2 (fun v t -> (((v, cxt'), env, prefix), t)) vars typs
+         @ vartyps,
+         exp_typ)
+    | Some ([_]) | Some ([]) | None ->
+        Format.fprintf ppf "type:@.%a@." Printtyp.type_expr typ;
+        failwith "TypeDebugger: Error in collect_one"
+  (*
+  match typ.desc with
+      Tlink (typ') -> collect_one ((vartyps, cxt'), env, prefix) vars typ'
+    | Ttuple (exp_typ :: typs) ->
+        (List.map2 (fun v t -> (((v, cxt'), env, prefix), t)) vars typs
+         @ vartyps,
+         exp_typ)
+    | _ ->
+        Format.fprintf ppf "type:@.%a@." Printtyp.type_expr typ;
+        failwith "TypeDebugger: Error in collect_one"
+  *)
+(*
+let rec collect_one ((vartyps, cxt'), env, prefix) p t = match t.desc with
+    Tarrow (_, t1, t2, _) ->
+      (obtain_pattern_types ((p, cxt'), env, prefix) t1 @ vartyps, t2)
+      (*
+      begin match p with
+          { ppat_desc = Ppat_var ({txt = st}) } ->
+            ((((st, cxt'), env, prefix), t1) :: vartyps, t2)
+        | _ -> (vartyps, t2) (* パターンが変数以外だったら無視されてる *)
+      end
+      *)
+  | Tlink (t') -> collect_one ((vartyps, cxt'), env, prefix) p t'
+  | _ -> failwith "TypeDebugger: Error in collect_one"
+*)
+
+(* collect : expression context_t -> type_expr -> yes_no_list * type_expr *)
+let rec collect ((expr, cxt), env, prefix) t = match cxt with
+    Empty -> ([], t)
+  | Lambda (pat, cxt') ->
+      (* There and back again [Danvy&Goldberg ICFP'02] *)
+      let (vartyps, t') = collect ((expr, cxt'), env, prefix) t in
+      let vars = pattern_variables pat in
+      begin match split_arrow t' with
+          Some ((*t1*)_, t2) ->
+            collect_one ((vartyps, cxt'), env, prefix) vars t2
+        | None -> (* Can't happen *)
+            failwith "TypeDebugger: Error in collect"
+      end
+  | Let (_, _, cxt') -> collect ((expr, cxt'), env, prefix) t
+
+(*
+let rec replace_pat st pat = match pat.ppat_desc with
+  | Ppat_any -> pat
+  | Ppat_var ({txt = st'}) ->
+     if st = st' then desc_to_pat Ppat_any pat else pat
+  | Ppat_alias (p, {txt = st'; loc = loc'}) ->
+     desc_to_pat (if st = st' then Ppat_any
+                  else (Ppat_alias (replace_pat st p, {txt = st';
+                                                       loc = loc'}))) pat
+  | Ppat_constant (_) -> dummy_pattern pat
+  | Ppat_interval (_, _) -> pat
+  | Ppat_tuple (ps) ->
+     desc_to_pat (Ppat_tuple (List.map (replace_pat st) ps)) pat
+  | Ppat_construct (lid, None) -> pat
+  | Ppat_construct (lid, Some (p)) ->
+     desc_to_pat (Ppat_construct (lid, Some (replace_pat st p))) pat
+  | Ppat_variant (_, None) -> pat
+  | Ppat_variant (l, Some (p)) ->
+     desc_to_pat (Ppat_variant (l, Some (replace_pat st p))) pat
+  | Ppat_record (lps, flg) ->
+     desc_to_pat (Ppat_record (List.map (fun (l, p) -> (l, replace_pat st p)) lps, flg)) pat
+  | Ppat_array (ps) ->
+     desc_to_pat (Ppat_array (List.map (replace_pat st) ps)) pat
+  | Ppat_or (p1, p2) ->
+     desc_to_pat (Ppat_or (replace_pat st p1, replace_pat st p2)) pat
+  | Ppat_constraint (p, ct) ->
+     desc_to_pat (Ppat_constraint (replace_pat st p, ct)) pat
+  | Ppat_type (_) -> pat
+  | Ppat_lazy (p) ->
+     desc_to_pat (Ppat_lazy (replace_pat st p)) pat
+  | Ppat_unpack ({txt = st'}) ->
+     if st = st' then desc_to_pat Ppat_any pat else pat
+  | Ppat_exception (p) ->
+     desc_to_pat (Ppat_exception (replace_pat st p)) pat
+  | Ppat_extension (_) -> pat
+  | Ppat_open (_, p) -> pat
+ *)
+let rec replace_pat st pat = match pat.ppat_desc with
+  | Ppat_any -> pat
+  | Ppat_var ({txt = st'}) ->
+     if st = st' then hole_of_pat pat else pat
+  | Ppat_alias (p, {txt = st'; loc = loc'}) ->
+     desc_to_pat (* if st = st' then pat.ppat_desc *) (* TODO:消していいかはチェックが必要。現状では全て残しておく *)
+                  (Ppat_alias (replace_pat st p, {txt = st';
+                                                       loc = loc'})) pat
+  | Ppat_constant _ -> dummy_any pat
+  | Ppat_interval _ -> pat
+  | Ppat_tuple (ps) ->     
+     desc_to_pat (Ppat_tuple (List.map (replace_pat st) ps)) pat
+  | Ppat_construct (_, None) -> pat
+  | Ppat_construct (lid, Some (p)) ->
+     desc_to_pat (Ppat_construct (lid, Some (replace_pat st p))) pat
+  | Ppat_variant (_, None) -> pat
+  | Ppat_variant (l, Some (p)) ->
+     desc_to_pat (Ppat_variant (l, Some (replace_pat st p))) pat
+  | Ppat_record (lps, flg) ->
+     desc_to_pat (Ppat_record (List.map (fun (l, p) -> (l, replace_pat st p)) lps, flg)) pat
+  | Ppat_array (ps) ->
+     desc_to_pat (Ppat_array (List.map (replace_pat st) ps)) pat
+  | Ppat_or (p1, p2) ->
+     desc_to_pat (Ppat_or (replace_pat st p1, replace_pat st p2)) pat
+  | Ppat_constraint (p, ct) ->
+     desc_to_pat (Ppat_constraint (replace_pat st p, ct)) pat
+  | Ppat_type _ -> pat
+  | Ppat_lazy (p) ->
+     desc_to_pat (Ppat_lazy (replace_pat st p)) pat
+  | Ppat_unpack ({txt = st'}) ->
+     if st = st' then hole_of_pat pat else pat
+  | Ppat_exception (p) ->
+     desc_to_pat (Ppat_exception (replace_pat st p)) pat
+  | Ppat_extension _ -> pat
+  | Ppat_open _ -> pat
+
+exception Pat_slice_error
+
+let try_empty_pat pat slice cxt env =
+  match (pattern_variables pat) with
+  | [] ->
+     let structure =  plug_str (cxt slice, Empty) in
+     if print_slice && !on_pat_slice then
+     Format.fprintf ppf "@[~try_empty_pat~: %a@]@." Pprintast.structure structure;
+     (try (ignore(Typemod.type_structure env structure Location.none); false) with
+     | _ ->  true)
+  | (*fst :: rest*)_ ->
+     false
+
+let get_slice_pat pat slice cxt env prefix =
+  let cxt'= unconstraint_pat pat Empty in
+  let cxt'= plug_cxt cxt cxt' in
+  let structure = plug_str (slice, cxt') in
+  let (structure', _, (*env'*)_) = (try(Typemod.type_structure env
+structure Location.none) with _ -> raise Pat_slice_error) in
+
+  match structure'.str_items with
+    {str_desc = Tstr_eval ({ exp_type = typ }, _)} :: [] ->
+    (* Ctype.occur_in env' typ *)
+    let (env'', typ') = collect ((slice, cxt'), env, prefix) typ in
+
+    let rec filter env t = match env with
+      | [] -> []
+      | (str_cxt, typ) :: rest ->
+         if Ctype.occur_in Env.empty typ t
+         then filter rest t
+         else str_cxt :: (filter rest t) in
+
+    let rec loop1 env t = match env with
+      | [] -> false
+      | (_, typ) :: rest ->
+         (if Ctype.occur_in Env.empty t typ then true else loop1 rest t) in
+
+    let rec loop env checked_env = match env with
+      | (str_cxt, typ') :: rest ->
+(if (Ctype.moregeneral Env.empty false typ' (Btype.newgenvar ())) then
+           (
+if loop1 (rest @ checked_env) typ'
+            then loop rest ((str_cxt, typ') :: checked_env)
+   else (str_cxt, typ') :: (loop rest ((str_cxt, typ') :: checked_env)))
+else (loop rest ((str_cxt, typ') :: checked_env)))
+      | [] -> [] in
+
+    let checked_env = (loop env'' []) in
+    let patvals = List.map (fun ((st, _), _, _) -> st) (filter
+checked_env typ') in
+    (* let patvals =
+      List.map (
+          fun ((st, _), _ ,_ ) -> st)(
+                 List.map fst (
+                            List.filter (
+                                function
+                                | (_, ({desc = Tvar _} as typ1)) ->
+                                   List.exists (
+                                       fun ((*str_cxt*)_, typ2) ->
+                                       Ctype.occur_in Env.empty typ1 typ2
+                                     ) env''
+                                | ((*str_cxt, typ1*)_, _) -> false
+                              ) env'')) in *)
+    List.fold_left (fun p v -> replace_pat v p) pat patvals
+  | _ -> failwith "TypeDebugger: Error in judge"
+
+(* let dummy_empty = Empty *)
+(* let dummy_let = Let (Nonrecursive, [], dummy_empty) *)
+
+
+(* slice のプログラム *)
+
+(* abst_one で必要な関数 *)
+(*
+let dummy_vb vb = map_vb hole_of_exp id vb
+and dummy_case case = map_case hole_of_exp id case
+and dummy_le le = map_le hole_of_exp id le
+ *)
+(* check_dummy : expression -> expression -> expression list
+                 -> expression_desc -> expression list *)
+and check_dummy e1 e2 es d =
+  (* e1 が □ でなければ e2 の pexp_desc を d に置き換えた要素を追加 *)
+  es @ (if e1 = hole_of_exp e1 then [] else [desc_to_exp d e2])
+(*  if e1 = dummy_assertfalse e1 then es else (desc_to_exp d e2 :: es) *)
+(* get_slice で必要な関数 *)
+(*
+let acc_e e = Map.set_exp Map.e1 e
+let acc_v v = Map.set_exp Map.v1 v
+let acc_c c = Map.set_exp Map.c1 c
+let acc_l l = Map.set_exp Map.le l
+ *)
+(* abst_inside : ('a -> 'a) -> 'a list -> 'a list -> 'a list -> 'a list -> 'a list *)
+(* expression を含む構文の要素の抽象化を試みて、□にならなかったものを返す *)
+let rec abst_inside map1 acc forward backword = match backword with
+  | [] -> List.rev acc
+  | tar :: backword' ->
+     (* チェック済 *)
+     let forward' = forward @ [tar] in
+     (* tar を□で置き換えることを試みる *)
+     let dummy = map1 hole_of_exp id tar in
+     let acc' =
+       if tar = dummy then acc else (forward @ (dummy :: backword')) :: acc in
+     abst_inside map1 acc' forward' backword'
+
+let abst_list map1 xs = abst_inside map1 [] [] xs
+
+(* abst_one : slice -> slice list *)
+(* 抽象化の本体 *)
+let abst_one exp =
+
+  let to_exp fd e xs = Desc.to_exp fd xs e exp in
+  let dummy_apply es =
+    Desc.e_apply (List.map (fun e -> (Nolabel, e)) es) skeleton' in
+
+  (* exp の構文で置き換えるようにする *)
+  let abst_some e d = check_dummy e exp [] d in
+  let abst_all ?(es = []) ?(e = skeleton') map1 fd xs =
+    check_dummy
+      e exp
+      (List.map (to_exp fd e) (abst_list map1 xs))
+      (if es = [] then fd xs (hole_of_exp e) else dummy_apply es) in
+
+(*
+  let abst_check_dummy' e xs fd_xs =
+    check_dummy e exp xs (fd_xs (hole_of_exp e)) in
+
+  let abst_all ?(use_dummy = None) ?(e = skeleton') map1 fd xs =
+    abst_check_dummy'
+      e (List.map (to_exp fd e) (abst_list map1 xs))
+      (match use_dummy with
+         None -> fd xs
+       | Some (fd') -> fd') in
+ *)
+
+  (* acc, forward はループの始めでは [] *)
+
+  (* abst_one のメイン部分 *)
+  match exp.pexp_desc with
+  | Pexp_let (flg, vs, e) ->
+     (* let 文 *)
+     (* let x = S1 in S2 => [let x = □ in S2; let x = S1 in □] *)
+(*
+     let d = Pexp_let (flg, vs, hole_of_exp e) in
+     let list =
+       List.map (fun vs' -> desc_to_exp (Pexp_let (flg, vs', e)) exp
+                ) (abst_list Map.v1 vs) in
+     abst_check_dummy e list d*)
+     abst_all ~e Map.v1 (Desc.e_let flg) vs
+
+  | Pexp_apply (e, les) ->
+     (* 関数適用 *)
+     (* @ S1 .. Sn => [=@ S1..Sn; @ □..Sn; ...; @ S1..□]  *)
+     abst_all ~e Map.le Desc.e_apply les
+(*
+     let d = Pexp_apply (hole_of_exp e, les) in
+     let list =
+       List.map (fun les' -> desc_to_exp (Pexp_apply (e, les')) exp
+                ) (abst_list Map.le les) in
+     abst_check_dummy e list d
+ *)
+  | Pexp_fun (l, eop, p, e) ->
+     (* fun文 *)
+     (* λx.S => λx.□ *)
+(*
+     let d = Pexp_fun (l, None, p, hole_of_exp e) in
+     abst_check_dummy e [] d
+ *)
+     abst_some e (Desc.e_fun l eop p (hole_of_exp e))
+  | Pexp_construct (lid, Some (e)) ->
+     (* コンストラクタ *)
+     (* 引数が単数か複数かで分岐 *)
+     let es = match e.pexp_desc with
+         Pexp_tuple es -> es
+       | _ -> [] in
+     abst_all
+       ~es ~e Map.e1 (Desc.e_construct lid) es
+(*
+     begin
+       match e.pexp_desc with
+       | Pexp_tuple (es) ->
+          let d = Pexp_apply (skeleton', List.map (fun e -> (Nolabel, e)) es) in
+          let list = List.map (fun es' -> desc_to_exp (Pexp_construct (l, Some (desc_to_exp (Pexp_tuple (es')) e))) exp) (abst_list Map.e1 es) in
+          abst_check_dummy e list d
+       | _ ->
+          let d = Pexp_construct (l, Some (hole_of_exp e)) in
+          abst_check_dummy e [] d
+     end
+ *)
+  | Pexp_match (e, cs) ->
+     (* match 文 *)
+     (* パターンする式と結果のみを対象にしている *)
+     (* match S0 with P1 -> S1 | ... | Pn -> Sn =>
+      [match □ with ...; ... with P1 -> □ | ...; ... with ... | Pn -> □] *)
+     abst_all ~e Map.c1 Desc.e_match cs
+(*
+     let d = Pexp_match (hole_of_exp e, cs) in
+     (* 式の抽象化 *)
+     let list =
+       List.map (
+           fun cs' -> desc_to_exp (Pexp_match (e, cs')) exp
+         ) (abst_list Map.c1 cs) in
+     (* パターンの抽象化 *)
+     abst_check_dummy e list d
+ *)
+  | Pexp_try (e, cs) ->
+     (* try 文 *)
+     (* パターンする式と結果のみを対象にしている *)
+     (* try S0 with P1 -> S1 | ... | Pn -> Sn =>
+      [try □ with ...; ... with P1 -> □ | ...; ... with ... | Pn -> □] *)
+     abst_all ~e Map.c1 Desc.e_try cs
+(*
+     let d = Pexp_try (hole_of_exp e, cs) in
+     let list =
+       List.map (fun cs' -> desc_to_exp (Pexp_try (e, cs')) exp
+                ) (abst_list Map.c1 cs) in
+     abst_check_dummy e list d
+ *)
+  | Pexp_tuple (es) ->
+     (* tuple *)
+     (* (S1, ... Sn) => [(□, ... Sn); ... ; (S1, ..., □); @= S1 ,..., Sn] *)
+     abst_all ~es Map.e1 Desc.e_tuple es
+(*
+     let d = Pexp_apply (skeleton', List.map (fun e -> (Nolabel, e)) es) in
+     let list =
+       List.map (fun es' -> desc_to_exp (Pexp_tuple (es')) exp
+                ) (abst_list Map.e1 es) in
+     abst_check_dummy skeleton' list d
+ *)
+  | Pexp_record (les, eop) ->
+     (* record *)
+     (* 各フィールドを対象にしている *)
+     abst_all
+       ~e:(match eop with None -> skeleton' | Some e -> e)
+       Map.le Desc.e_record les
+(*
+     List.map (fun les' -> desc_to_exp (Pexp_record (les', None)) exp
+              ) (abst_list Map.le les)
+ *)
+  | Pexp_array (es) ->
+     (* array *)
+     abst_all ~es Map.e1 Desc.e_array es
+(*
+     let d = Pexp_apply (skeleton', List.map (fun e -> (Nolabel, e)) es) in
+     let list =
+       List.map (fun es' -> desc_to_exp (Pexp_array (es')) exp
+                ) (abst_list Map.e1 es) in
+     abst_check_dummy skeleton' list d
+ *)
+  | Pexp_ifthenelse (e1, e2, eop) ->
+     (* ifthenelse *)
+     (* [if □ then e2 else e3; if e1 then □ else e3; if e1 then e2 else □] *)
+     let fd sel =
+       Desc.e_ifthenelse
+         (if sel = 1 then hole_of_exp e1 else e1)
+         (if sel = 2 then hole_of_exp e2 else e2)
+         (match eop with
+            Some (e3) when sel = 3 -> Some (hole_of_exp e3)
+          | _ -> eop) in
+     (abst_some e1 (fd 1)) @ (abst_some e2 (fd 2))
+     @ (match eop with None -> [] | Some e3 -> abst_some e3 (fd 3))
+(*
+     abst_check_dummy e1 [] (Pexp_ifthenelse (hole_of_exp e1, e2, e3))
+     @ abst_check_dummy e2 [] (Pexp_ifthenelse (e1, hole_of_exp e2, e3))
+     @ begin
+         match e3 with
+         | Some (e) ->
+            abst_check_dummy e [] (Pexp_ifthenelse (e1, e2, Some (hole_of_exp e)))
+         | None -> []
+       end
+ *)
+  (* sequence *)
+  | Pexp_constraint (e, c) ->
+     (* constraint *)
+     (* [(□ : c)] *)
+     abst_all ~e Map.e1 (Desc.e_constraint c) []
+(*
+     abst_check_dummy e [] (Pexp_constraint (hole_of_exp e, c))
+ *)
+(*  | Pexp_constant _ -> [exp] *)
+  | _ -> if exp = hole_of_exp exp then [] else [hole_of_exp exp]
+(*
+(* search *)
+(* search : (slice list * (slice -> slice) * (unit -> slice)) -> Env.t -> slice *)
+let rec search (slices, cxt, f) env pat_cxt =
+  match slices with
+  | [] ->
+     let ret = f () in
+     if print_slice
+     then (Format.fprintf ppf "@[  return: %a@]@."
+           print_deb_exp ret);
+     ret
+  | first :: rest ->
+     if print_slice
+     then (Format.fprintf ppf "@[  first: %a@]@."
+           print_deb_exp first);
+     try
+       (* Warnings.parse_options false "-A"; *)
+       let structure = [Str.eval (cxt first)] in
+       ignore (
+           Typemod.type_structure env structure Location.none
+         );
+       (* Warnings.parse_options false Warnings.defaults_w; *)
+       (* welltyped *)
+       if print_slice
+       then (Format.fprintf ppf "@[  welltyped : %a@]@."
+                            print_deb_exp (cxt first);
+             Format.fprintf ppf "@[~search~@]@.");
+       search (rest, cxt, f) env pat_cxt
+     with
+     | Typetexp.Error _
+     | Typecore.Error _ ->
+        (* illtyped *)
+        (* Warnings.parse_options false Warnings.defaults_w; *)
+        if print_slice
+        then (Format.fprintf ppf "@[  illtyped : %a@]@."
+                             print_deb_exp (cxt first);
+              Format.fprintf ppf "@[~get_slice~@]@.");
+       get_slice (first, cxt) env pat_cxt
+
+(* get_slice *)
+(* (slice * (slice -> slice)) -> Env.t -> slice *)
+and get_slice (slice, cxt) env pat_cxt =
+  (* 抽象化する *)
+  let abst =
+    let lst = abst_one slice in
+    if print_slice then
+      (Format.fprintf ppf "@[~abst_one~@]@.";
+       List.iter (
+           fun a -> Format.fprintf ppf "@[  %a@]@." print_deb_exp a
+         ) lst;
+       Format.fprintf ppf "@[~search~@]@.");
+    lst in
+  (* search に渡す *)
+  let make_thunk lst fun_acc fun_all fun_one fun_desc =
+    (* s_all : 全てのリストの処理が終わった後の仕上げで必要な関数 *)
+    (* s_one : 着目している式での処理を行う関数 *)
+    (* fun_desc : acc と s_all を与えると desc が求まる関数 *)
+    (* 各構文での処理中では、上の順番で定義する *)
+    let rec slice_loop lst acc = match lst with
+      | [] ->
+         let s_all = get_slice' (fun_all acc) env pat_cxt in
+         let d = fun_desc acc s_all in
+         desc_to_exp d slice
+      | first :: rest ->
+         let s_one = get_slice' (fun_one first rest acc) env pat_cxt in
+         slice_loop rest (acc @ [fun_acc first s_one]) in
+    (* ここでサンクを作る *)
+    fun () -> slice_loop lst [] in
+  (* スライスを求める部分の本体 *)
+  match slice.pexp_desc with
+  | Pexp_let (flg, vs, e) -> (* let文 *)
+     let fun_all acc =
+       (e, (fun y -> cxt (desc_to_exp (Pexp_let (flg, acc, y)) slice))) in
+     let fun_one vb _ acc =
+       (vb.pvb_expr, (fun y -> cxt (desc_to_exp (Pexp_let (flg, acc @ [acc_v vb y], e)) slice))) in
+     let fun_desc acc s_all = Pexp_let (flg, acc, s_all) in
+     search (abst, cxt, make_thunk vs acc_v fun_all fun_one fun_desc) env pat_cxt
+(*
+     let rec loop vs a = match vs with
+       | [] ->
+          let sn' =
+            get_slice' (e, (fun y -> cxt (desc_to_exp (Pexp_let (flg, a, y)) slice))) env pat_cxt in
+          desc_to_exp (Pexp_let (flg, a, sn')) slice
+       | {pvb_pat = p; pvb_expr = sn; pvb_attributes = atrs; pvb_loc = l} as vb :: rest ->
+          let s' = get_slice' (sn, (fun y -> cxt (desc_to_exp (Pexp_let (flg, a @ [acc_v vb y], e)) slice))) env pat_cxt in
+          loop rest (a @ [{pvb_pat = p; pvb_expr = s'; pvb_attributes = atrs; pvb_loc = l}]) in
+     search (abst, cxt, fun () -> loop vs []) env pat_cxt
+ *)
+  | Pexp_apply (e, les) ->
+     (* 関数適用 *)
+     let fun_all acc =
+       (e, (fun x -> cxt (desc_to_exp (Pexp_apply (x, acc)) slice))) in
+     let fun_one (l, sn) rest acc =
+       (sn, (fun y -> cxt (desc_to_exp (Pexp_apply (get_slice' (fun_all les) env pat_cxt, (acc @ [(l, y)] @ rest))) slice))) in
+     let fun_desc acc s_all = Pexp_apply (s_all, acc) in
+(*
+     let rec loop les a = match les with
+         [] -> desc_to_exp (Pexp_apply (s0', a)) slice
+       | (l, sn) :: rest ->
+          let s' =
+            get_slice' (sn, (fun x -> cxt (desc_to_exp (Pexp_apply (s0', a @ [(l, x)] @ rest)) slice))) env in
+          loop rest (a @ [(l, s')]) in *)
+     search (abst, cxt, make_thunk les acc_l fun_all fun_one fun_desc) env pat_cxt
+  | Pexp_match (e, cs) ->
+     (* サンクを作る *)
+     let fun_all acc =
+       (e, (fun x -> cxt (desc_to_exp (Pexp_match (x, acc)) slice))) in
+     let fun_one c rest acc =
+       (c.pc_rhs, (fun x -> cxt (desc_to_exp (Pexp_match (get_slice' (fun_all cs) env pat_cxt, (acc @ [acc_c c x] @ rest))) slice))) in
+     let fun_desc acc s_all = Pexp_match (s_all, acc) in
+     let slice' = search (abst, cxt, make_thunk cs acc_c fun_all fun_one fun_desc) env pat_cxt in
+     if not (!on_pat_slice)
+     then slice'
+     else
+     begin
+       match slice'.pexp_desc with
+       | Pexp_match (e, cs) ->
+          if print_slice && !on_pat_slice then
+            Format.fprintf ppf "@[~get_slice_pat~: %a@]@." Pprintast.expression slice';
+          let cs' = List.map (fun c -> try ({pc_lhs = get_slice_pat c.pc_lhs c.pc_rhs pat_cxt env []; pc_guard = c.pc_guard; pc_rhs = c.pc_rhs}) with Pat_slice_error -> c) cs in
+          let rec loop cs acc = match cs with
+            | [] -> List.rev acc
+            | {pc_lhs = p; pc_guard = g; pc_rhs = e'} :: rest ->
+              let emp_pat = ({pc_lhs = desc_to_pat Ppat_any p; pc_guard = g; pc_rhs = e'}) in
+               if try_empty_pat p (desc_to_exp (Pexp_match (e, (acc @ [emp_pat] @ rest))) slice') cxt env
+               then loop rest (acc @ [emp_pat])
+               else loop rest (acc @ [{pc_lhs = p; pc_guard = g; pc_rhs = e'}])  in
+          let cs' = loop cs' [] in
+          desc_to_exp (Pexp_match (e, cs')) slice'
+       | _ -> assert false
+     end
+(*
+     let slice' = search (abst, cxt, (* fun () -> loop cs [] *) make_thunk cs acc_c fun_all fun_one fun_desc) env in
+     begin
+       match slice'.pexp_desc with
+       | Pexp_match (e', cs') ->
+       if Debug_core.print_slice && !Debug_core.on_pat_slice then
+         Format.fprintf ppf "@[~get_slice_pat~: %a@]@." Pprintast.expression slice';
+       if (not !Debug_core.on_pat_slice)
+       then slice' (* let文の定義の中、もしくは *)
+       else desc_to_exp (Pexp_match (e', List.map (fun {pc_lhs = p; pc_guard = g; pc_rhs = e} -> {pc_lhs = get_slice_pat p e Empty env []; pc_guard = g; pc_rhs = e}) cs')) slice'
+       | _ -> assert false
+     end
+ *)
+(* =======
+     let slice' =
+       search (abst, cxt, (* fun () -> loop cs [] *) make_thunk cs acc_c fun_all fun_one fun_desc) env in
+     slice'
+
+>>>>>>> Stashed changes *)
+  | Pexp_try (e, cs) ->
+     (* try 文 *)
+     (* ほぼ match と同じ *)
+     let fun_all acc =
+       (e, (fun x -> cxt (desc_to_exp (Pexp_try (x, acc)) slice))) in
+     let fun_one c rest acc =
+       (c.pc_rhs, (fun x -> cxt (desc_to_exp (Pexp_try (get_slice' (fun_all cs) env pat_cxt, (acc @ [acc_c c x] @ rest))) slice))) in
+     let fun_desc acc s_all = Pexp_try (s_all, acc) in
+     search (abst, cxt, make_thunk cs acc_c fun_all fun_one fun_desc) env pat_cxt
+  | Pexp_fun (l, None, p, e) ->
+     (* 関数 *)
+     (* λx.S => λx.□ *)
+     let pat_cxt' = unconstraint_pat p Empty in
+     let pat_cxt'= plug_cxt pat_cxt pat_cxt' in
+     let slice' = search (abst, cxt, (fun () -> desc_to_exp (Pexp_fun (l, None, p, get_slice' (e, (fun y -> cxt (desc_to_exp (Pexp_fun (l, None, p,  y)) slice))) env pat_cxt')) slice)) env pat_cxt' in
+     if not (!on_pat_slice)
+     then slice'
+     else
+     begin
+     match slice'.pexp_desc with
+     | Pexp_fun (l, None, p, e) ->
+       if print_slice && !on_pat_slice then
+         Format.fprintf ppf "@[~get_slice_pat~: %a@]@." Pprintast.expression slice';
+       (* if (!inner_let || (not !Debug_core.on_pat_slice))
+       then slice' (* let文の定義の中、もしくは *)
+       else *)
+       let p' = try(get_slice_pat p e pat_cxt env [])
+                with Pat_slice_error -> p in
+       let slice' = (desc_to_exp (Pexp_fun (l, None, p', e)) slice') in
+
+       let pat_empty_slice = (desc_to_exp (Pexp_fun (l, None, desc_to_pat Ppat_any p', e)) slice') in
+       if (try_empty_pat p' pat_empty_slice cxt env)
+       then pat_empty_slice
+       else slice'
+     | _ -> assert false
+     end
+  | Pexp_tuple (es) ->
+     (* 関数適用 *)
+     let fun_all _ = (skeleton', id) in
+     let fun_one sn rest acc =
+       (sn, (fun x -> cxt (desc_to_exp (Pexp_tuple (acc @ [x] @ rest)) slice))) in
+     let fun_desc acc _ = Pexp_tuple (acc) in
+     search (abst, cxt, make_thunk es acc_e fun_all fun_one fun_desc) env pat_cxt
+  | Pexp_construct (l, Some (e)) ->
+     (* コンストラクタ *)
+     (* 引数がある場合について考える *)
+     begin
+       match e.pexp_desc with
+       | Pexp_tuple (es) ->
+          let fun_all _ = (skeleton', id) in
+          let fun_one sn rest acc =
+            (sn, (fun x -> cxt (desc_to_exp (Pexp_construct (l, Some (desc_to_exp (Pexp_tuple (acc @ [x] @ rest)) e))) slice))) in
+          let fun_desc acc _ = Pexp_construct (l, Some (desc_to_exp (Pexp_tuple (acc)) e)) in
+          search (abst, cxt, make_thunk es acc_e fun_all fun_one fun_desc) env pat_cxt
+       | _ ->
+          search (abst, cxt, (fun () -> desc_to_exp (Pexp_construct (l, Some (get_slice' (e, cxt) env pat_cxt))) slice)) env pat_cxt
+     end
+(*
+     search (abst, cxt, (fun () -> desc_to_exp (Pexp_construct (l, Some (get_slice (e, cxt) env pat_cxt))) slice)) env pat_cxt
+ *)
+  | Pexp_record (les, None) ->
+     (* レコード *)
+     let fun_all _ = (skeleton', id) in
+     let fun_one (l, sn) rest acc =
+       (sn, (fun x -> cxt (desc_to_exp (Pexp_record (acc @ [(l, x)] @ rest, None)) slice))) in
+     let fun_desc acc _ = Pexp_record (acc, None) in
+     search (abst, cxt, make_thunk les acc_l fun_all fun_one fun_desc) env pat_cxt
+  | Pexp_array (es) ->
+     (* 配列 *)
+     let fun_all _ = (skeleton', id) in
+     let fun_one sn rest acc =
+       (sn, (fun x -> cxt (desc_to_exp (Pexp_array (acc @ [x] @ rest)) slice))) in
+     let fun_desc acc _ = Pexp_array (acc) in
+     search (abst, cxt, make_thunk es acc_e fun_all fun_one fun_desc) env pat_cxt
+  | Pexp_ifthenelse (e1, e2, e3) ->
+     (* ifthenelse *)
+     search (abst,cxt, (
+                   fun () ->
+                   let s1' =
+                     get_slice' (e1, (fun y -> cxt (desc_to_exp (Pexp_ifthenelse (y, e2, e3)) slice))) env pat_cxt in
+                   let s2' =
+                     get_slice' (e2, (fun y -> cxt (desc_to_exp (Pexp_ifthenelse (s1', y, e3)) slice))) env pat_cxt in
+                   let s3' =
+                     match e3 with
+                     | None -> None
+                     | Some (e3') ->
+                        Some (get_slice' (e3', (fun y -> cxt (desc_to_exp (Pexp_ifthenelse (s1', s2', Some (y))) slice))) env pat_cxt) in
+                   desc_to_exp (Pexp_ifthenelse (s1', s2', s3')) slice)) env pat_cxt
+(*
+  | Pexp_ident _ -> slice    (* 変数 *)
+  | Pexp_constant _ -> slice (* 定数 *)
+  | Pexp_variant _ -> slice
+ *)
+  | _ -> slice
+(* get_slice' *)
+and get_slice' (slice, cxt) env pat_cxt =
+  if slice = hole_of_exp slice
+  then slice
+  else get_slice (slice, cxt) env pat_cxt
+
+(* judge : expression context_t -> yes_no_list * type_expr *)
+let judge ((expr, cxt), env, prefix) =
+  let structure = plug_str (expr, cxt) in
+  let (structure', _, _) = Typemod.type_structure env structure Location.none in
+  match structure'.str_items with
+    {str_desc = Tstr_eval ({ exp_type = typ }, _)} :: [] ->
+      collect ((expr, cxt), env, prefix) typ
+  | _ -> failwith "TypeDebugger: Error in judge"
+ *)
+(*
+let get_type_expr ((expr, cxt), env, prefix) =
+  try
+    (* expr(fun文)の型を求める *)
+    let (_, typ) = judge ((expr, cxt), env, prefix) in
+    begin
+      match split_arrow typ with
+      | Some (t, _) -> Some (t)
+      | None -> Some (typ)
+    end
+  with _ -> None (* Noneが返されるということは、矢印でなかったもしくはエラー *)
+
+(* レコードの補完 *)
+(* complete_pat_record : expression context_t
+   -> (Longident.t loc * pattern) list -> pattern_desc *)
+let complete_pat_record ((expr, cxt), env, prefix) (lps, flg) =
+  match get_type_expr ((expr, cxt), env, prefix) with
+  | None -> Ppat_any
+  | Some (dummy_t) ->
+     (* レコードのパターンの置き換えを行う *)
+     (* 各フィールドのダミーを作る *)
+     let dummy_lps =
+       List.map (
+           fun {pld_name = {txt = t; loc = l}} ->
+           ({txt = Longident.parse t; loc = l}, wildcard)
+         ) (decode_labels dummy_t prefix) in
+     (* lps の要素を順に dummy_lps に当てはめていく *)
+     let lps' =
+       List.fold_left (
+           (* lst : 置き換えの対象 *)
+           (* (ln, pn) : パターン中の一要素 *)
+           fun lst (ln, pn) ->
+           List.map (
+               fun (lm, pm) ->
+               if Longident.last lm.txt = Longident.last ln.txt
+               then (ln, pn) else (lm, pm)) lst
+         ) dummy_lps lps in
+     (* record の desc を返す *)
+     Ppat_record (lps', flg)
+
+let dummy_fun pat =
+  desc_to_exp (Pexp_fun (Nolabel, None, pat, skeleton')) skeleton'
+
+let rec complete_pat ((expr, cxt), env, prefix) pat = match pat.ppat_desc with
+  | Ppat_any -> pat
+  | Ppat_var _ -> pat
+  | Ppat_alias (p, loc) ->
+     let p' = complete_pat ((expr, cxt), env, prefix) p in
+     let d = Ppat_alias (p', loc) in
+     desc_to_pat d pat
+  | Ppat_constant _ -> pat
+  | Ppat_interval _ -> pat
+  | Ppat_tuple (ps) ->
+     let ps' = List.map (
+                   fun pn -> complete_pat ((expr, cxt), env, prefix) pn) ps in
+     let d = Ppat_tuple (ps') in
+     desc_to_pat d pat
+  | Ppat_record (lps, flg) ->
+     (* レコード *)
+     (* 足りないフィールドを補う *)
+     let d = complete_pat_record ((expr, cxt), env, prefix) (lps, flg) in
+     desc_to_pat d pat
+  | Ppat_or (p1, p2) ->
+     let p1' = complete_pat ((expr, cxt), env, prefix) p1 in
+     let p2' = complete_pat ((expr, cxt), env, prefix) p2 in
+     let d = Ppat_or (p1', p2') in
+     desc_to_pat d pat
+  | _ -> pat
+
+let rec sort_vb env vs = match vs with
+  | [] -> []
+  | first :: rest ->
+     (* first のみで定義した関数がエラーになるかどうかをチェック *)
+     try
+       ignore (Typemod.type_structure env [Str.value Recursive [first]] Location.none); first :: sort_vb env rest
+     with
+     | _ -> (sort_vb env rest) @ [first]
+
+let rec complete ((expr, cxt), env, prefix) =  match expr.pexp_desc with
+  | Pexp_ident _ -> expr
+  | Pexp_constant _ -> expr
+  | Pexp_let (flg, vs, exp) ->
+     let exp' = complete ((exp, cxt), env, prefix) in
+     let vs' =
+       List.map (map_vb (fun e -> complete ((e, cxt), env, prefix)) id) vs in
+     let d' = Pexp_let (flg, sort_vb env vs', exp') in
+     desc_to_exp d' expr
+  | Pexp_function cs ->
+     (* function | P1 -> E1 | ... *)
+     (* csに含まれるパターン全てに対して同じように処理する *)
+     let cs' =
+       List.map (
+           let fe = fun e -> complete ((e, cxt), env, prefix) in
+           let fp = fun p -> complete_pat ((dummy_fun p, cxt), env, prefix) p in
+           map_case fe fp) cs in
+     let d' = Pexp_function (cs') in
+     desc_to_exp d' expr
+  | Pexp_fun (l, eop, pat, exp) ->
+     (* fun P -> E *)
+     (* Pの型をチェックする *)
+     let pat' = complete_pat ((dummy_fun pat, cxt), env, prefix) pat in
+     let exp' = complete ((exp, cxt), env, prefix) in
+     let d' = Pexp_fun (l, eop, pat', exp') in
+     desc_to_exp d' expr
+  | Pexp_apply (e0, les) ->
+     (* E0 E1 E2 ... *)
+     let e0' = complete ((e0, cxt), env, prefix) in
+     let les' =
+       List.map (map_le (fun en -> complete ((en, cxt), env, prefix)) id) les in
+     let d' = Pexp_apply (e0', les') in
+     desc_to_exp d' expr
+  | Pexp_match (e, cs) ->
+     (* match E0 with P1 -> E1 | ... *)
+     (* csに含まれるパターン全てに対して同じように処理する *)
+     let e' = complete ((e, cxt), env, prefix) in
+     let cs' =
+       List.map (
+           let fe = fun e -> complete ((e, cxt), env, prefix) in
+           let fp = fun p -> complete_pat ((dummy_fun p, cxt), env, prefix) p in
+           map_case fe fp) cs in
+     let d' = Pexp_match (e', cs') in
+     desc_to_exp d' expr
+  | Pexp_try (e, cs) ->
+     (* try E0 with P1 -> E1 | ... *)
+     (* csに含まれるパターン全てに対して同じように処理する *)
+     let e' = complete ((e, cxt), env, prefix) in
+     let cs' =
+       List.map (
+           let fe = fun e -> complete ((e, cxt), env, prefix) in
+           let fp = fun p -> complete_pat ((dummy_fun p, cxt), env, prefix) p in
+           map_case fe fp) cs in
+     let d' = Pexp_try (e', cs') in
+     desc_to_exp d' expr
+  | Pexp_tuple (es) ->
+     let es' = List.map (fun en -> complete ((en, cxt), env, prefix)) es in
+     let d' = Pexp_tuple (es') in
+     desc_to_exp d' expr
+  | Pexp_construct (lid, Some (e)) ->
+     let e' = complete ((e, cxt), env, prefix) in
+     let d' = Pexp_construct (lid, Some (e')) in
+     desc_to_exp d' expr
+  | Pexp_variant (l, Some (e)) ->
+     let e' = complete ((e, cxt), env, prefix) in
+     let d' = Pexp_variant (l, Some (e')) in
+     desc_to_exp d' expr
+  | Pexp_record (les, eop) ->
+     let les' =
+       List.map (
+           map_le (fun en -> complete ((en, cxt), env, prefix)) id
+         ) les in
+     let eop' = match eop with
+       | None -> None
+       | Some (e) -> Some (complete ((e, cxt), env, prefix)) in
+     let d' = Pexp_record (les', eop') in
+     desc_to_exp d' expr
+  | Pexp_field (e, lid) ->
+     let e' = complete ((e, cxt), env, prefix) in
+     let d' = Pexp_field (e', lid) in
+     desc_to_exp d' expr
+  | Pexp_setfield (e1, lid, e2) ->
+     let e1' = complete ((e1, cxt), env, prefix) in
+     let e2' = complete ((e2, cxt), env, prefix) in
+     let d' = Pexp_setfield (e1', lid, e2') in
+     desc_to_exp d' expr
+  | Pexp_array (es) ->
+     let es' = List.map (fun en -> complete ((en, cxt), env, prefix)) es in
+     let d' = Pexp_array (es') in
+     desc_to_exp d' expr
+  | Pexp_ifthenelse (e1, e2, eop) ->
+     let e1' = complete ((e1, cxt), env, prefix) in
+     let e2' = complete ((e2, cxt), env, prefix) in
+     let eop' = match eop with
+       | None -> None
+       | Some (e) -> Some (complete ((e, cxt), env, prefix)) in
+     let d' = Pexp_ifthenelse (e1', e2', eop') in
+     desc_to_exp d' expr
+  | Pexp_sequence (e1, e2) ->
+     let e1' = complete ((e1, cxt), env, prefix) in
+     let e2' = complete ((e2, cxt), env, prefix) in
+     let d' = Pexp_sequence (e1', e2') in
+     desc_to_exp d' expr
+  | _ -> expr
+ *)
+(*
+module Pattern_slicing : sig
+end = struct
+end
+ *)
+
+
+module Complete = struct
+
+  let dummy_fun pat =
+    desc_to_exp (Pexp_fun (Nolabel, None, pat, skeleton')) skeleton'
+
+  (* pattern complete *)
+  let rec pattern ((pat, cxt), env, prefix) =
+
+    (* パターンに対する補完を行う *)
+    let pat' p = go pattern prefix env cxt p in
+
+    let desc d = desc_to_pat d pat in
+    let map1 y1 ys = List.map (y1 id pat') ys in
+    let to_pat fd fy ?(p = wildcard) ys =
+      Desc.to_pat fd (fy ys) (pat' p) pat in
+
+    match pat.ppat_desc with
+    | Ppat_any -> pat
+    | Ppat_var _ -> pat
+    | Ppat_alias (p, lid) ->
+       to_pat (Desc.p_alias lid) id ~p []
+    | Ppat_constant _ -> pat
+    | Ppat_interval _ -> pat
+    | Ppat_tuple (ps) ->
+       to_pat Desc.p_tuple (map1 Map.p1) ps
+(*
+       desc (Ppat_tuple (List.map pat' ps)) *)
+    | Ppat_construct (lid, Some (p)) ->
+       to_pat (Desc.p_construct lid) id ~p []
+    | Ppat_variant (l, Some (p)) ->
+       to_pat (Desc.p_variant l) id ~p []
+
+    | Ppat_record (lps, flg) ->
+       (* レコード *)
+       (* 足りないフィールドを補う *)
+       let lps' =
+         try
+           let (_, exp_typ) = judge ((dummy_fun pat, cxt), env, prefix) in
+           let pat_typ = match split_arrow exp_typ with
+               Some (t, _) -> t
+             | None -> exp_typ in
+           if print_slice then
+             Format.fprintf ppf "@[  make dummy labels: type %a @]@."
+                            Printtyp.type_expr pat_typ;
+
+           let dummy_lps =
+             List.map (
+                 fun {pld_name = {txt = t; loc = l}} ->
+                 ({txt = Longident.parse t; loc = l}, wildcard)
+               ) (decode_labels pat_typ prefix) in
+
+           List.fold_left (
+               fun lst (ln, pn) ->
+               List.map (
+                   fun (lm, pm) ->
+                   if Longident.last lm.txt = Longident.last ln.txt
+                   then (ln, pn) else (lm, pm)) lst
+             ) dummy_lps lps
+         with
+           _ -> lps in
+       to_pat (Desc.p_record flg) (map1 Map.lp) lps'
+
+(*
+       desc (Ppat_record (lps', flg))
+ *)
+    | Ppat_array (ps) ->
+       to_pat Desc.p_array (map1 Map.p1) ps
+    | Ppat_or (p1, p2) ->
+       desc (Ppat_or (pat' p1, pat' p2))
+    | Ppat_constraint (p, c) ->
+       to_pat (Desc.p_constraint c) id ~p []
+    | _ -> pat
+
+  (* expression complete *)
+  let rec expression ((expr, cxt), env, prefix) =
+
+    let go' f x = go f prefix env cxt x in
+    let exp' e = go' expression e in
+    let pat' p = go' pattern p in
+
+    (* 式に対する補完を行う *)
+    let desc d = desc_to_exp d expr in
+    let map1 x1 xs = List.map (x1 exp' pat') xs in
+    let to_exp fd fx ?(e = skeleton') xs =
+      Desc.to_exp fd (fx xs) (exp' e) expr in
+
+    match expr.pexp_desc with
+    | Pexp_let (flg, vs, e) ->
+       to_exp (Desc.e_let flg) (go' value_bindings) ~e vs
+(*
+       let vs' = go' value_bindings vs in
+       let d' = Pexp_let (flg, vs', exp' e) in
+       desc d'
+ *)
+    | Pexp_function cs ->
+       (* function | P1 -> E1 | ... *)
+       (* csに含まれるパターン全てに対して同じように処理する *)
+       to_exp Desc.e_function (go' cases) cs
+(*
+       let d' = Pexp_function (go' cases cs) in
+       desc d'
+ *)
+    | Pexp_fun (l, eop, p, e) ->
+       (* fun P -> E *)
+       (* Pの型をチェックする *)
+       let d' = Pexp_fun (l, eop, pat' p, exp' e) in
+       desc d'
+    | Pexp_apply (e, les) ->
+       (* E0 E1 E2 ... *)
+       to_exp Desc.e_apply (map1 Map.le) ~e les
+(*
+       let les' = List.map (Map.le exp' id) les in
+       let d' = Pexp_apply (exp' e, les') in
+       desc d'
+ *)
+    | Pexp_match (e, cs) ->
+       (* match E0 with P1 -> E1 | ... *)
+       (* csに含まれるパターン全てに対して同じように処理する *)
+       to_exp Desc.e_match (go' cases) ~e cs
+(*
+       let cs' = List.map (Map.c1 exp' pat') cs in
+       let d' = Pexp_match (exp' e, cs') in
+       desc d'
+ *)
+    | Pexp_try (e, cs) ->
+       (* try E0 with P1 -> E1 | ... *)
+       (* csに含まれるパターン全てに対して同じように処理する *)
+       to_exp Desc.e_try (go' cases) ~e cs
+(*
+       let cs' = List.map (Map.c1 exp' pat') cs in
+       let d' = Pexp_try (exp' e, cs') in
+       desc d'
+ *)
+    | Pexp_tuple (es) ->
+       to_exp Desc.e_tuple (map1 Map.e1) es
+(*
+       desc (Pexp_tuple (List.map exp' es))
+ *)
+    | Pexp_construct (lid, Some (e)) ->
+       to_exp (Desc.e_construct lid) id ~e []
+(*
+       let d' = Pexp_construct (lid, Some (exp' e)) in
+       desc d'
+ *)
+    | Pexp_variant (l, Some (e)) ->
+       to_exp (Desc.e_variant l) id ~e []
+(*
+       let d' = Pexp_variant (l, Some (exp' e)) in
+       desc d'
+ *)
+    | Pexp_record (les, eop) ->
+       let e = match eop with
+           None -> skeleton' | Some e -> e in
+       to_exp Desc.e_record (map1 Map.le) ~e les
+(*
+       let les' = List.map (Map.le exp' id) les in
+       let eop' = match eop with
+         | None -> None
+         | Some (e) -> Some (exp' e) in
+       let d' = Pexp_record (les', eop') in
+       desc d'
+ *)
+    | Pexp_field (e, lid) ->
+       to_exp (Desc.e_field lid) id ~e []
+(*
+       desc (Pexp_field (exp' e, lid))
+ *)
+    | Pexp_setfield (e1, lid, e2) ->
+(*
+       let d' = Pexp_setfield (exp' e1, lid, exp' e2) in
+       desc d'
+ *)
+       desc (Desc.e_setfield lid (exp' e1) (exp' e2))
+    | Pexp_array (es) ->
+       to_exp Desc.e_array (map1 Map.e1) es
+(*
+       desc (Pexp_array (List.map exp' es))
+ *)
+    | Pexp_ifthenelse (e1, e2, eop) ->
+(*
+       let eop' = match eop with
+         | None -> None
+         | Some (e3) -> Some (exp' e3) in
+       let d' = Pexp_ifthenelse (exp' e1, exp' e2, eop') in *)
+       desc (Desc.e_ifthenelse
+               (exp' e1) (exp' e2)
+               (match eop with None -> None | Some e3 -> Some (exp' e3)))
+    | Pexp_sequence (e1, e2) ->
+       desc (Desc.e_sequence (exp' e1) (exp' e2))
+(*
+       desc (Pexp_sequence (exp' e1, exp' e2))
+ *)
+    | _ -> expr
+
+  and value_bindings ((vs, cxt), env, prefix) = match vs with
+    | [] -> []
+    | vn :: rest ->
+       let vn' =
+         Map.v1 (go expression prefix env cxt)
+                (go pattern prefix env cxt) vn in
+       (* vn のみで定義した関数がエラーになるかどうかをチェック *)
+       let rest' = value_bindings ((rest, cxt), env, prefix) in
+       try
+         ignore (
+             Typemod.type_structure
+               env [Str.value Recursive [vn']] Location.none);
+         vn' :: rest'
+       with
+       | _ -> rest' @ [vn']
+
+  and cases ((cs, cxt), env, prefix) =
+    List.map (Map.c1 (go expression prefix env cxt)
+                     (go pattern prefix env cxt)) cs
+end
+
+module Expression_slicing : sig
+  (* Expression のスライシング *)
+  val get :
+    (expression * expr_cxt) * item_cxt -> Env.t -> expr_context
+    -> expression
+
+end = struct
+
+  let rec search (slices, exp_cxt, item_cxt, f) env cxt = match slices with
+    | [] ->
+       let ret = f () in
+       if print_slice then
+         begin
+           Format.fprintf ppf "@[~search~@]@.";
+           Format.fprintf ppf "@[  return: %a@]@."print_deb_exp ret
+         end;
+       ret
+    | first :: rest ->
+       if print_slice && first <> hole_of_exp first then
+         begin
+           Format.fprintf ppf "@[~search~@]@.";
+           List.iter (
+               fun a ->
+               if a <> hole_of_exp a
+               then Format.fprintf ppf "@[  %a@]@." 
+                                   print_deb_exp a
+             ) (List.rev rest)
+         end;
+
+       (* 部分的に抽象化した結果、エラーになるかどうかをチェック *)
+       let structure = item_cxt exp_cxt first in
+       try
+         (* Warnings.parse_options false "-A"; *)
+         ignore (
+             Typemod.type_structure env structure Location.none
+           );
+         (* Warnings.parse_options false Warnings.defaults_w; *)
+         (* welltyped *)
+         if print_slice && first <> hole_of_exp first
+         then (Format.fprintf ppf "@[  welltyped : %a@]@."
+                              print_deb_strs structure);
+         search (rest, exp_cxt, item_cxt, f) env cxt
+       with
+         Typetexp.Error _
+       | Typecore.Error _ ->
+          (* illtyped *)
+          (* Warnings.parse_options false Warnings.defaults_w; *)
+          if print_slice
+          then (Format.fprintf ppf "@[  illtyped : %a@]@."
+                               print_deb_strs structure);
+          get ((first, exp_cxt), item_cxt) env cxt
+
+  (* get *)
+  and get ((slice, exp_cxt), item_cxt) env pat_cxt =
+
+    (* 与えた fd 等から desc_to_exp *)
+    let slice' ?(e = slice) ?(s_all = skeleton') acc fd =
+      Desc.to_exp fd acc s_all e in
+    (* exp_cxt に desc から作った式を与える *)
+    let exp_cxt' fd acc s_all = exp_cxt (slice' ~s_all acc fd) in
+    (* slice * exp_cxt と pat_cxt を与えて get' する *)
+    let sn' ?(c = pat_cxt) x = get' (x, item_cxt) env c in
+
+    let e_in_v v = v.pvb_expr in
+    let e_in_c c = c.pc_rhs in
+    let e_in_l l = snd l in
+
+    let f1_cxt acc_x fd e x rest acc y =
+      exp_cxt' fd (acc @ [acc_x x y] @ rest) e in
+(*
+    let f1_v acc_x fd e v rest acc =
+      (e_in_v v, f1_cxt acc_x fd e v rest acc) in
+    let f1_l acc_x fd e l rest acc =
+      (e_in_l l, f1_cxt acc_x fd e l rest acc) in
+    let f1_c acc_x fd e c rest acc =
+      (e_in_c c, f1_cxt acc_x fd e c rest acc) in
+    let f1_e acc_x fd e s rest acc =
+      (s, f1_cxt acc_x fd e s rest acc) in
+    let no_f1 _ _ e _ _ _ = (e, id) in
+ *)
+    let no_fp acc _ s_all fd = slice' ~s_all acc fd in
+    let rec fp lst acc s_all fd = match lst with
+      | [] ->
+         if print_slice && !on_pat_slice then
+           Format.fprintf ppf "@[~finish get_slice_pat~@]@.";
+         slice' ~s_all acc fd
+      | c :: rest ->
+         let ({pc_lhs = p'} as c') =
+           try
+             Map.c2 (fun _ e -> e)
+                    (fun p e -> get_slice_pat p e pat_cxt env []) c
+           with Pat_slice_error -> c in
+         let emp_pat = Map.c1 id dummy_any c' in
+         if try_empty_pat p' (slice' ~s_all (acc @ [emp_pat] @ rest) fd) exp_cxt env
+         then fp rest (acc @ [emp_pat]) s_all fd
+         else fp rest (acc @ [c']) s_all fd in
+
+    let rec fp_v lst acc s_all fd = match lst with
+      | [] ->
+         if print_slice && !on_pat_slice then
+           Format.fprintf ppf "@[~finish get_slice_pat~@]@.";
+         slice' ~s_all acc fd
+      | v :: rest ->
+         let ({pvb_pat = p'} as v') =
+           try
+             Map.v1
+               id (fun p -> get_slice_pat p s_all pat_cxt env []) v
+           with Pat_slice_error -> v in
+         let emp_pat = Map.v1 id dummy_any v' in
+         if try_empty_pat p' (slice' ~s_all (acc @ [emp_pat] @ rest) fd) exp_cxt env
+         then fp_v rest (acc @ [emp_pat]) s_all fd
+         else fp_v rest (acc @ [v']) s_all fd in
+
+    (* search に渡す *)
+    let make_thunk ?(e = skeleton') xs x1 fx ?(fp = no_fp) fd =
+
+      (* s_all : 全てのリストの処理が終わった後の仕上げで必要な関数 *)
+      (* s_one : 着目している式での処理を行う関数 *)
+      (* fd : acc と s_all を与えると desc が求まる関数 *)
+      (* 各構文での処理中では、上の順番で定義する *)
+      let acc_x x = Map.set_exp x1 x in
+      let rec get_slice xs acc = match xs with
+        | [] ->
+           let s_all = sn' (e, exp_cxt' fd acc) in
+           Size.set_all (if !on_pat_slice then fp
+                         else no_fp ) fd fx acc s_all
+        | first :: rest ->
+           let s_one = sn' (fx first, f1_cxt acc_x fd e first rest acc) in
+           get_slice rest (acc @ [acc_x first s_one]) in
+
+      (* return で呼び出される部分 *)
+      get_slice xs [] in
+
+
+    (* サンクの定義 *)
+    let f () = match slice.pexp_desc with
+
+      | Pexp_let (flg, vs, e) ->
+         (* let文 *)
+         let fp = if flg = Recursive then no_fp else fp_v in
+         make_thunk ~e vs Map.v1 e_in_v ~fp (Desc.e_let flg)
+(*
+         let fd acc s_all = Pexp_let (flg, acc, s_all) in
+         let f1 = f1_v in
+         let fp = if flg = Recursive then no_fp else fp_v in
+         make_thunk ~e vs acc_v ~fp f1 fd pat_cxt
+ *)
+
+      | Pexp_apply (e, les) ->
+         (* 関数適用 *)
+         make_thunk ~e les Map.le e_in_l Desc.e_apply
+(*
+         let fd acc s_all = Pexp_apply (s_all, acc) in
+         let f1 = f1_l in
+         make_thunk ~e les acc_l f1 fd pat_cxt
+ *)
+      | Pexp_match (e, cs) ->
+         (* match 文 *)
+         make_thunk ~e cs Map.c1 ~fp e_in_c Desc.e_match
+(*
+         let fd acc s_all = Pexp_match (s_all, acc) in
+         let f1 = f1_c in
+         make_thunk ~e cs acc_c ~fp f1 fd pat_cxt
+ *)
+      | Pexp_try (e, cs) ->
+         (* try 文 *)
+         make_thunk ~e cs Map.c1 ~fp e_in_c Desc.e_try
+(*
+         let fd acc s_all = Pexp_try (s_all, acc) in
+         let f1 = f1_c in
+         make_thunk ~e cs acc_c ~fp f1 fd pat_cxt
+ *)
+      | Pexp_function cs ->
+         (* function *)
+         make_thunk cs Map.c1 ~fp e_in_c Desc.e_function
+(*
+         let fd acc _ = Pexp_function acc in
+         let f1 = f1_c in
+         make_thunk cs acc_c ~fp f1 fd pat_cxt
+ *)
+      | Pexp_fun (l, None, p, e) ->
+         (* 関数抽象 *)
+         (* fun P -> E *)
+         let fd ?(pat = p) _ s_all = Pexp_fun (l, None, pat, s_all) in
+         let c = plug_cxt pat_cxt (Lambda (p, Empty)) in
+         let s_all = sn' ~c (e, exp_cxt' fd []) in
+         let n = Size.get s_all in
+         Size.set_one
+           ~n
+           (if not !on_pat_slice then slice' ~s_all [] fd
+            else
+              let pat = try (get_slice_pat p s_all pat_cxt env [])
+                        with Pat_slice_error -> p in
+              let s' = slice' ~s_all [] (fd ~pat) in
+              let pat_empty_slice =
+                slice' ~s_all [] (fd ~pat:(hole_of_pat pat)) in
+
+            if try_empty_pat pat pat_empty_slice exp_cxt env
+            then pat_empty_slice else s')
+
+      | Pexp_tuple (es) ->
+         (* 関数適用 *)
+         make_thunk es Map.e1 id Desc.e_tuple
+(*
+         let fd acc _ = Pexp_tuple (acc) in
+         let f1 = f1_e in
+         make_thunk es acc_e f1 fd pat_cxt
+ *)
+      | Pexp_construct (lid, Some (e)) ->
+         (* コンストラクタ *)
+         (* 引数がある場合について考える *)
+         let (es', e') = match e.pexp_desc with
+             Pexp_tuple es -> (es, skeleton')
+           | _ -> ([], e) in
+         let fd acc s_all =
+           Desc.e_construct lid [] (if es' = []
+                                    then s_all
+                                    else slice' ~e acc Desc.e_tuple) in
+
+         make_thunk ~e:e' es' Map.e1 id fd
+
+      | Pexp_record (les, eop) ->
+         (* レコード *)
+         let e = match eop with None -> skeleton' | Some e -> e in
+         make_thunk ~e les Map.le e_in_l Desc.e_record
+(*
+         let fd acc _ = Pexp_record (acc, eop) in
+         let f1 = f1_l in
+         make_thunk les acc_l f1 fd pat_cxt
+ *)
+      | Pexp_array (es) ->
+         (* 配列 *)
+         make_thunk es Map.e1 id Desc.e_array
+(*
+         let fd acc _ = Pexp_array (acc) in
+         let f1 = f1_e in
+         make_thunk es acc_e f1 fd pat_cxt
+ *)
+      | Pexp_ifthenelse (e1, e2, eop) ->
+         (* ifthenelse *)
+         let fd ?(s1 = e1) ?(s2 = e2) ?(s3 = skeleton') _ _ =
+           Desc.e_ifthenelse
+             s1 s2 (if s3 = skeleton' then eop else Some s3) in
+(*
+           Pexp_ifthenelse (s1, s2, if s3 = skeleton' then eop else Some s3) in
+ *)
+         let exp_cxt'' fd' = exp_cxt' fd' [] skeleton' in
+         let e1_cxt' s1 = exp_cxt'' (fd ~s1) in
+         let s1 = sn' (e1, e1_cxt') in
+         let e2_cxt' s2 = exp_cxt'' (fd ~s1 ~s2) in
+         let s2 = sn' (e2, e2_cxt') in
+         let e3_cxt' s3 = exp_cxt'' (fd ~s1 ~s2 ~s3) in
+         let s3 = match eop with
+           | None -> skeleton'
+           | Some (e3) -> sn' (e3, e3_cxt') in
+
+         (* if文のサイズは、各式のサイズから求める *)
+         let n =
+           Size.get ~n:0 s1 + Size.get ~n:0 s2 + Size.get s3 in
+         Size.set_one ~n (slice' [] (fd ~s1 ~s2 ~s3))
+
+      | Pexp_constraint (e, ct) ->
+         (* (E : core_type) *)
+         make_thunk ~e [] Map.e1 id (Desc.e_constraint ct)
+
+      | _ -> Size.set_one slice in (* その他構文は全て size 1 として扱う *)
+
+    (* search を呼び出す *)
+    search (abst_one slice, exp_cxt, item_cxt, f) env pat_cxt
+
+  (* get' *)
+  and get' ((slice, exp_cxt), item_cxt) env pat_cxt =
+    if slice = hole_of_exp slice then Size.set_one slice (* □ は size 1 *)
+    else get ((slice, exp_cxt), item_cxt) env pat_cxt
+
+end
+
+module Structure_slicing : sig
+
+  (* structure のスライシング *)
+  val get :
+    (structure_cxt * structure_item * structure) context_t -> structure
+
+end = struct
+
+  (* search *)
+  (* structure のスライスを1行ずつ求める。 *)
+  let rec search (str_cxt, prefix, slice_str) cxt = match prefix with
+      [] -> str_cxt [] slice_str
+    | (next_str, env) :: rest ->
+       try
+         let (s', env') = List.hd rest in
+         ignore (Typemod.type_structure
+                   env' (str_cxt rest (s' :: slice_str)) Location.none);
+         raise Not_found
+       with
+       | Typecore.Error _ ->
+          (* Typecore.Error *)
+          (* next_str を無視しても型エラーが残る *)
+          if print_slice then
+            Format.fprintf ppf "@[ignore: %a@]@."
+                           print_deb_strs [next_str];
+          search (str_cxt, rest, slice_str) cxt
+       | _ ->
+          (* Typetexp.Error, slice_str が空 *)
+          (* next_str を無視したら型エラーが消える *)
+          go get rest env cxt (str_cxt, next_str, slice_str)
+
+  (* 着目している行のスライスを求める。 *)
+  and get (((str_cxt, item, slice_str), cxt), env, prefix) = match item with
+      {pstr_desc = d; pstr_loc = loc} ->
+      (* item をスライシングして、slice_str を更新する。 *)      
+      let slice_str' = match d with
+        | Pstr_eval (expr, _) ->
+           (* eval *)
+           let eval_cxt e = (Str.eval ~loc e) :: slice_str in
+           go eval prefix env cxt
+              (str_cxt, eval_cxt, go Complete.expression prefix env cxt expr)
+        (*           eval (((str_cxt, (eval_cxt, expr), slice_str), cxt), env, prefix) *)
+        | Pstr_value (flg, vs) when item <> hole_str ->
+           (* value *)
+           let value_cxt vs = (Str.value ~loc flg vs) :: slice_str in
+           if print_slice then
+             Format.fprintf ppf "@[~go to complete~@]@.";
+           go value prefix env cxt
+              (str_cxt, value_cxt, go Complete.value_bindings prefix env cxt vs)
+(*
+           let vs' = Complete.value_bindings ((vs, cxt), env, prefix) in
+           value (((str_cxt, (value_cxt, vs'), slice_str), cxt), env, prefix) *)
+        | Pstr_module ({pmb_loc; pmb_name = name;
+                        pmb_expr = {pmod_loc; pmod_attributes = [];
+                                    pmod_desc = Pmod_structure (mod_str)}}) ->
+           (* module *)
+           let me_cxt str =
+             Mod.structure ~loc:pmod_loc
+                           ~attrs:[mkloc "mod" loc, PStr mod_str;
+                                   mknoloc "size", Size (List.length mod_str)] str in
+           let mb_cxt str =
+             Mb.mk ~loc:pmb_loc name (me_cxt str) in
+           let mod_cxt str =
+             (Str.module_ ~loc (mb_cxt str)) :: slice_str in
+           let str_cxt' prefix' structure' =
+             mod_cxt (
+                 List.fold_left (
+                     fun str (s', _) -> s' :: str) structure' prefix') in
+           go module_ [] env cxt (str_cxt', mod_str)
+(*           module_ (((mod_str, str_cxt'), cxt), env, []) *)
+        | _ -> item :: slice_str in
+
+      (* search に移動 *)
+      search (str_cxt, prefix, slice_str') cxt
+
+  (* get' *)
+  (* Expression_slicing に行く *)
+  (* ひとつ前の行の環境があれば使う。なければ現在の環境を使う。 *)
+  and get' (((str_cxt, f, expr), cxt), env, prefix) =
+
+    let slice_cxt prefix str exp_cxt slice =
+      str_cxt prefix (str @ f (exp_cxt slice)) in
+    let (item_cxt, env') = match prefix with
+        [] -> (slice_cxt prefix [], env)
+      | (s', env') :: prefix' ->
+         try
+           ignore (
+               Typemod.type_structure env (f skeleton') Location.none);
+           (* □に置き換えて welltyped: *)
+           (slice_cxt prefix [], env)
+         with _ ->
+           (* □に置き換えて illtyped: *)
+           (slice_cxt prefix' [s'], env') in
+
+    Expression_slicing.get ((expr, id), item_cxt) env' cxt
+
+  (* Eval : (structure_cxt * (expression -> structure) * expression) context_t
+     -> structure *)
+  (* eval のスライシング *)
+  and eval (((str_cxt, eval_cxt, expr), cxt), env, prefix) =
+    let slice =
+      go get' prefix env cxt (str_cxt, eval_cxt, expr) in
+    if print_slice then
+      Format.fprintf ppf "@[get_slice_eval: %a @]@."
+                     print_deb_strs (eval_cxt slice);
+    eval_cxt slice
+
+  (* value *)
+  (* value のスライシング *)
+  and value (((str_cxt, value_cxt, vs), cxt), env, prefix) = match vs with
+      [] -> value_cxt []
+    | vn :: rest ->
+       (* vn のスライスを求める *)
+       let value_cxt' e vs' = value_cxt ((Map.set_exp Map.v1 vn e) :: vs') in
+       let vb_cxt e = value_cxt' e rest in
+       let slice =
+         go get' prefix env cxt (str_cxt, vb_cxt, vn.pvb_expr) in
+       if print_slice then
+         Format.fprintf ppf "@[get_slice_value: %a @]@."
+                        print_deb_strs (value_cxt' slice []);
+       go value prefix env cxt (str_cxt, value_cxt' slice, rest)
+
+  (* module *)
+  (* (structure_cxt * (structure -> structure) * structure) context_t
+     -> structure *)
+  (* module のスライシング *)
+  and module_ (((str_cxt, structure), cxt), env, prefix) = match structure with
+    | [] -> search (str_cxt, prefix, []) cxt
+    | s :: rest ->
+       try
+         (* rest のみ無視したモジュールで型がつくかどうかチェックする *)
+         ignore (
+             Typemod.type_structure
+               env [List.hd (str_cxt prefix [s])] Location.none);
+         (* prefix に積んで再帰 *)
+         go module_ ((s, env) :: prefix) env cxt (str_cxt, rest)
+       with _ ->
+         (* モジュールの中で型エラー *)
+         go get prefix env cxt (str_cxt, s, [])
+
+end
+
+(* スライスの入口 *)
+let rec top structure env prefix = match structure with
+    [] -> failwith "TypeDebugger: Error: structure is well typed."
+  | s :: rest ->
+     try
+       let (_, _, env') =
+         Typemod.type_structure env [s] Location.none in
+       top rest env' ((s, env) :: prefix)
+     with _ ->
+       let structure_cxt _ str = str in
+       go Structure_slicing.get prefix env Empty (structure_cxt, s, [])
+(*
+       Structure_slicing.get (((structure_cxt, s, []), Empty), env, prefix)
+ *)
+
+
+let get_slice_top structure env =
+  Warnings.parse_options false "-A";
+  (* スライス結果 *)
+  top structure env []
+
+(*
+
+(* check_lst : 要素の扱いを記録する
+       None  ... 無視
+  Some true  ... スライスされた
+  Some false ... スライスされていない *)
+let flg_value = Some true
+let flg_eval = None
+let flg_other = Some false
+
+(* [let P1 = E1 in ... let Pn = En in E0] を
+   [let P1 = E1; ...; let Pn = En; E0 (skeleton の場合は省く)] に変換する *)
+let rec get_slice_last {pstr_desc = d; pstr_loc = loc1} env prefix =
+  match d with
+  | Pstr_module _ -> assert false (* のちに考慮 *)
+  | Pstr_value (flg, vs) ->
+     (* eval の let文への変換が必要 *)
+     let exp = Exp.let_ ~loc:loc1 flg vs skeleton' in
+     get_slice_last (Str.eval ~loc:loc1 exp) env prefix
+  | Pstr_eval ({pexp_desc = Pexp_let (flg, vs, e); pexp_loc = loc2}, _) ->
+     (* value に戻す *)
+     (Str.value ~loc:loc2 flg vs) ::
+       get_slice_last (Str.eval ~loc:e.pexp_loc e) env prefix
+  | Pstr_eval (exp, _) when exp <> skeleton' ->
+     [Str.eval ~loc:loc1 exp] (* in exp は eval に変換 *)
+  | _ -> [] (* in □ はいらない *)
+
+(* {pstr_desc = d1; pstr_loc = loc1} *)
+let get_slice_next ({pstr_desc = d2; pstr_loc = loc2}, strs) env prefix =
+  (* str2の式を抜き出す *)
+  (* 式があったらここでcompleteを入れる方が良い？ *)
+  let exp2 = match d2 with
+    | Pstr_eval (exp, _) -> exp
+    | Pstr_value (flg, vs) ->
+       Exp.let_ ~loc:loc2 flg vs skeleton'
+    | _ -> skeleton' in
+  (* str1の式にexp2を含める *)
+  (* vs の sort も complete で行う *)
+  let exp1 = complete ((exp2, Empty), env, prefix) in
+  if print_slice then
+    begin
+      Format.fprintf ppf "@[~complete~@]@.";
+      Format.fprintf ppf "@[  before: %a @]@." Pprintast.expression exp2;
+      Format.fprintf ppf "@[   after: %a @]@." Pprintast.expression exp1;
+    end;
+  match strs with
+  | {pstr_desc = Pstr_value (flg, vs); pstr_loc = loc1} :: rest ->
+     (* str1とstr2を合わせてスライスを求める *)
+     let slice = get_slice (Exp.let_ ~loc:loc1 flg vs exp1, id) env Empty in
+     (Str.eval slice, rest)
+  | _ ->
+     let slice = get_slice (exp1, id) env Empty in
+     (Str.eval slice, [])
+
+(* last : 今見ている中で一番下の行に相当するstructure_item *)
+(* strs : これから見ていくstructure *)
+let rec get_slice_values (last, strs) env prefix =
+  (* last を抽象化 *)
+  let (next, strs') = get_slice_next (last, strs) env prefix in
+  if strs' = [] then get_slice_last next env prefix
+  else get_slice_values (next, strs') env prefix
+
+let rec get_slice_others check_lst (others, values) env prefix =
+  match check_lst with
+  | [] -> values (* values に illtyped の式が残っている *)
+  | first :: rest ->
+     if first = flg_value then
+       match values with
+         [] -> []
+       | v :: vs -> v :: get_slice_others rest (others, vs) env prefix
+     else if first = flg_other then
+       match others with
+         [] -> []
+       | o :: os -> o :: get_slice_others rest (os, values) env prefix
+     else get_slice_others rest (others, values) env prefix
+
+(* strs : 型エラーになるかどうかチェックしたい structure *)
+let rec get_slice_strs ?(check_lst = []) ?(prefix = []) ?(others = []) ?(values = []) strs env = match strs with
+  | [] -> assert false
+  | first :: rest ->
+     try
+       (* first でエラーが出るかどうかをチェック *)
+       (* Warnings.parse_options false "-A"; *)
+       let (_, _, env') =
+         Typemod.type_structure env [first] first.pstr_loc in
+       let prefix' = (first, env) :: prefix in
+       (* Warnings.parse_options false Warnings.defaults_w; *)
+       if first = hole_str then
+         get_slice_strs
+           ~check_lst:(check_lst @ [flg_other]) ~prefix:prefix'
+           ~others:(first :: others) ~values rest env'
+       else
+         match first.pstr_desc with
+         | Pstr_eval _ ->
+            get_slice_strs
+              ~check_lst:(check_lst @ [flg_eval]) ~prefix
+              ~others ~values rest env'
+         | Pstr_value _ ->
+            (* 関数・変数の定義：values 側に積む *)
+            if print_slice
+            then Format.fprintf ppf "@[This structure_item (%a) is value.@]@." Pprintast.structure [first];
+            get_slice_strs
+              ~check_lst:(check_lst @ [flg_value]) ~prefix:prefix'
+              ~others ~values:(first :: values) rest env'
+         | _ ->
+            (* それ以外：others 側に積む *)
+            if print_slice
+            then Format.fprintf ppf "@[This structure_item (%a) is't value.@]@." Pprintast.structure [first];
+            get_slice_strs
+              ~check_lst:(check_lst @ [flg_other]) ~prefix:prefix'
+              ~others:(first :: others) ~values rest env'
+     with
+       Typetexp.Error _
+     | Typecore.Error _ ->
+        (* エラーになった *)
+        (* Warnings.parse_options false Warnings.defaults_w; *)
+        (* values が空ならば、そのまま slice に移行 *)
+        if print_slice
+        then Format.fprintf ppf "@[This structure_item (%a) is illtyped.@]@." Pprintast.structure [first];
+        (* value 部分とエラーが出た部分のスライスを求める *)
+        let values' = get_slice_values (first, values) env prefix in
+        (* 順番を正しくする *)
+        get_slice_others check_lst (List.rev others, values') env prefix
+  *)                       
+(*
+and get_slice_str ?(is_slice = false) (acc_b, ({pstr_desc = d; pstr_loc = loc} as str), acc_f) env prefix =
+  let slice_to_eval exp = Str.eval ~loc exp in
+  let slice_to_value exp = match exp.pexp_desc with
+    | Pexp_let (flg, vs, _) -> Str.value ~loc flg vs
+    | _ -> assert false in
+  (* desc ごとに必要な処理を行う *)
+  match d with
+  | _ when is_slice -> str
+  | Pstr_eval (exp, _) ->
+     if print_slice then Format.fprintf ppf "@[~slice_to_eval~@]@.";
+     get_slice_str' (acc_b, (slice_to_eval, exp), acc_f) env prefix
+  | Pstr_value (flg, vs) ->
+     if print_slice then Format.fprintf ppf "@[~slice_to_value~@]@.";
+     let exp = Exp.let_ ~loc flg vs skeleton in
+     get_slice_str' (acc_b, (slice_to_value, exp), acc_f) env prefix
+  | _ -> str
+
+and get_slice_str' (acc_b, (f, exp), acc_f) env prefix =
+  let exp' = complete ((exp, Empty), env, prefix) in
+  let slice = get_slice (acc_b, acc_f) (exp', id) env Empty in
+  get_slice_str ~is_slice:true (acc_b, (f slice), acc_f) env prefix
+*)
+(*
+
+let get_slice_top str _ =
+  print_endline "slicer launched.";
+  str
+
+ *)
diff --git a/typing/debug_slice.mli b/typing/debug_slice.mli
new file mode 100644
index 0000000..a2ccfd9
--- /dev/null
+++ b/typing/debug_slice.mli
@@ -0,0 +1,3 @@
+open Parsetree
+
+val get_slice_top : structure -> Env.t -> structure
