diff -urN ocaml-4.02.1-org/Makefile ocaml-4.02.1/Makefile
--- ocaml-4.02.1-org/Makefile	2014-09-24 10:12:13.000000000 +0900
+++ ocaml-4.02.1/Makefile	2015-05-14 11:39:51.000000000 +0900
@@ -61,7 +61,7 @@
   typing/includemod.cmo typing/typetexp.cmo typing/parmatch.cmo \
   typing/stypes.cmo typing/typecore.cmo \
   typing/typedecl.cmo typing/typeclass.cmo \
-  typing/typemod.cmo
+  typing/typemod.cmo typing/debug_message.cmo typing/debug_main.cmo
 
 COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \
   bytecomp/typeopt.cmo bytecomp/switch.cmo bytecomp/matching.cmo \
diff -urN ocaml-4.02.1-org/driver/compile.ml ocaml-4.02.1/driver/compile.ml
--- ocaml-4.02.1-org/driver/compile.ml	2014-08-07 17:52:02.000000000 +0900
+++ ocaml-4.02.1/driver/compile.ml	2015-05-14 11:39:51.000000000 +0900
@@ -60,6 +60,13 @@
   let modulename = module_of_filename ppf sourcefile outputprefix in
   Env.set_unit_name modulename;
   let env = Compmisc.initial_env() in
+  (* launch type debugger if necessary *)
+  let algo comp phr =
+    try comp phr
+    with Typecore.Error (_, _, _) as x ->
+      Errors.report_error ppf x; 
+      Debug_main.algo (Parsetree.Ptop_def phr) (Compmisc.initial_env());
+      exit 2 in
   if !Clflags.print_types then begin
     let comp ast =
       ast
@@ -72,7 +79,7 @@
       Warnings.check_fatal ();
       Stypes.dump (Some (outputprefix ^ ".annot"))
     in
-    try comp (Pparse.parse_implementation ~tool_name ppf sourcefile)
+    try algo comp (Pparse.parse_implementation ~tool_name ppf sourcefile)
     with x ->
       Stypes.dump (Some (outputprefix ^ ".annot"));
       raise x
@@ -97,7 +104,7 @@
       close_out oc;
       Stypes.dump (Some (outputprefix ^ ".annot"))
     in
-    try comp (Pparse.parse_implementation ~tool_name ppf sourcefile)
+    try algo comp (Pparse.parse_implementation ~tool_name ppf sourcefile)
     with x ->
       close_out oc;
       remove_file objfile;
diff -urN ocaml-4.02.1-org/parsing/parser.mly ocaml-4.02.1/parsing/parser.mly
--- ocaml-4.02.1-org/parsing/parser.mly	2014-09-26 10:34:10.000000000 +0900
+++ ocaml-4.02.1/parsing/parser.mly	2015-05-14 11:39:51.000000000 +0900
@@ -19,6 +19,16 @@
 open Parsetree
 open Ast_helper
 
+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
@@ -289,6 +299,18 @@
 let mkctf_attrs d attrs =
   Ctf.mk ~loc:(symbol_rloc()) ~attrs d
 
+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)))
+
+let deprecated str1 str2 loc =
+  raise (Syntaxerr.Error (Syntaxerr.Deprecated
+          (str1, str2, language_level, loc)))
+
 %}
 
 /* Tokens */
@@ -1033,8 +1055,12 @@
 
 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)) }
 ;
 labeled_simple_pattern:
     QUESTION LPAREN label_let_pattern opt_default RPAREN
@@ -1110,18 +1136,30 @@
   | 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
@@ -1151,15 +1189,21 @@
   | expr GREATER expr
       { mkinfix $1 ">" $3 }
   | expr OR expr
-      { mkinfix $1 "or" $3 }
+      { if language_level < 4
+        then deprecated "||" "or" (rhs_loc 2)
+        else mkinfix $1 "or" $3 }
   | expr BARBAR expr
       { mkinfix $1 "||" $3 }
   | expr AMPERSAND expr
-      { mkinfix $1 "&" $3 }
+      { if language_level < 4
+        then deprecated "&&" "&" (rhs_loc 2)
+        else mkinfix $1 "&" $3 }
   | 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 -urN ocaml-4.02.1-org/parsing/syntaxerr.ml ocaml-4.02.1/parsing/syntaxerr.ml
--- ocaml-4.02.1-org/parsing/syntaxerr.ml	2014-06-03 21:25:01.000000000 +0900
+++ ocaml-4.02.1/parsing/syntaxerr.ml	2015-05-14 11:39:51.000000000 +0900
@@ -10,6 +10,19 @@
 (*                                                                     *)
 (***********************************************************************)
 
+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") ||  (String.sub lang 0 (min 5 (String.length lang)) = "en_US.ISO8859-1")
+  then Japanese
+  else English
+with Not_found -> English
+
+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 =
@@ -18,6 +31,9 @@
   | 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
+  | Deprecated of string * string * int * Location.t
   | Other of Location.t
   | Ill_formed_ast of Location.t * string
 
@@ -50,6 +66,46 @@
         "Error: 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
+  | Deprecated (str1, str2, level, loc) ->          
+      errorf ~loc
+        "L%dError7: %s is deprecated.  Use %s instead."
+        "L%dError7: %s はもう使えません。%s を使いましょう。"
+        level str2 str1
   | Other loc ->
       Location.error ~loc "Error: Syntax error"
   | Ill_formed_ast (loc, s) ->
@@ -74,6 +130,9 @@
   | Not_expecting (l, _)
   | Ill_formed_ast (l, _)
   | Expecting (l, _) -> l
+  | Expert_exp (_, _, l) -> l
+  | InfixOP0 (_, _, l) -> l
+  | Deprecated (_, _, _, l) -> l
 
 
 let ill_formed_ast loc s =
diff -urN ocaml-4.02.1-org/parsing/syntaxerr.mli ocaml-4.02.1/parsing/syntaxerr.mli
--- ocaml-4.02.1-org/parsing/syntaxerr.mli	2014-06-03 21:25:01.000000000 +0900
+++ ocaml-4.02.1/parsing/syntaxerr.mli	2015-05-14 11:39:51.000000000 +0900
@@ -20,6 +20,9 @@
   | 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
+  | Deprecated of string * string * int * Location.t
   | Other of Location.t
   | Ill_formed_ast of Location.t * string
 
diff -urN ocaml-4.02.1-org/toplevel/toploop.ml ocaml-4.02.1/toplevel/toploop.ml
--- ocaml-4.02.1-org/toplevel/toploop.ml	2014-10-13 16:18:19.000000000 +0900
+++ ocaml-4.02.1/toplevel/toploop.ml	2015-05-14 11:39:51.000000000 +0900
@@ -237,6 +237,10 @@
 
 let directive_table = (Hashtbl.create 13 : (string, directive_fun) Hashtbl.t)
 
+(* structures input so far in the reverse order *)
+(* added for Type debugger *)
+let rev_structures = ref []
+
 (* Execute a toplevel phrase *)
 
 let execute_phrase print_outcome ppf phr =
@@ -276,6 +280,7 @@
               Ophr_exception (exn, outv)
         in
         !print_out_phrase ppf out_phr;
+	rev_structures := sstr :: !rev_structures;
         begin match out_phr with
         | Ophr_eval (_, _) | Ophr_signature _ -> true
         | Ophr_exception _ -> false
@@ -349,6 +354,7 @@
       end
     in
     let lb = Lexing.from_channel ic in
+    let last_phrase = ref (Ptop_def []) in
     Location.init lb filename;
     (* Skip initial #! line if any *)
     Lexer.skip_sharp_bang lb;
@@ -358,6 +364,7 @@
           List.iter
             (fun ph ->
               let ph = preprocess_phrase ppf ph in
+	      last_phrase := ph; (* here? *)
               if not (execute_phrase !use_print_results ppf ph) then raise Exit)
             (if wrap_mod then
                parse_mod_use_file name lb
@@ -367,6 +374,11 @@
         with
         | Exit -> false
         | Sys.Break -> fprintf ppf "Interrupted.@."; false
+	| Typecore.Error (_, _, _) as x ->
+           Errors.report_error ppf x; 
+           Debug_main.algo2 !last_phrase !rev_structures
+                            (Compmisc.initial_env ());
+           false
         | x -> Location.report_exception ppf x; false) in
     if must_close then close_in ic;
     success
@@ -471,6 +483,7 @@
   fprintf ppf "        OCaml version %s@.@." Config.version;
   initialize_toplevel_env ();
   let lb = Lexing.from_function refill_lexbuf in
+  let last_phrase = ref (Ptop_def []) in
   Location.init lb "//toplevel//";
   Location.input_name := "//toplevel//";
   Location.input_lexbuf := Some lb;
@@ -484,12 +497,17 @@
       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; (* here? *)
       Env.reset_cache_toplevel ();
       ignore(execute_phrase true ppf phr)
     with
     | End_of_file -> exit 0
     | Sys.Break -> fprintf ppf "Interrupted.@."; Btype.backtrack snap
     | PPerror -> ()
+    | Typecore.Error (_, _, _) as x ->
+       Errors.report_error ppf x; 
+       Debug_main.algo2 !last_phrase !rev_structures
+                        (Compmisc.initial_env ());
     | x -> Location.report_exception ppf x; Btype.backtrack snap
   done
 
diff -urN ocaml-4.02.1-org/typing/debug_main.ml ocaml-4.02.1/typing/debug_main.ml
--- ocaml-4.02.1-org/typing/debug_main.ml	1970-01-01 09:00:00.000000000 +0900
+++ ocaml-4.02.1/typing/debug_main.ml	2015-05-14 11:39:51.000000000 +0900
@@ -0,0 +1,1629 @@
+(* open Misc *)
+(* open Path *)
+open Asttypes
+open Ast_helper
+
+open Types
+open Typedtree
+(* open Ctype *)
+(* open Format *)
+
+open Parsetree
+open Debug_message
+
+module type A_t = sig
+  val algo : Parsetree.toplevel_phrase -> Env.t -> unit
+  val algo2 : Parsetree.toplevel_phrase -> Parsetree.structure list -> Env.t -> unit
+end
+
+module A : A_t = struct (* beginning of module **********************)
+
+let ppf = Format.std_formatter
+
+let language_level = try
+  let lang = Sys.getenv "OCAML_LANGUAGE_LEVEL" in
+  begin match lang with
+    "1" -> 1
+  | "2" -> 2
+  | "3" -> 3
+  | "4" -> 4
+  | _ -> 4
+  end
+with Not_found -> 4
+
+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
+
+(* dummy_int0 : expression *)
+let dummy_int0 = {
+  pexp_desc       = Pexp_constant (Const_int 0);
+  pexp_loc        = Location.none;
+  pexp_attributes = [];
+}
+
+(* dummy_false : expression *)
+let dummy_false = {
+  pexp_desc       = Pexp_construct (mknoloc (Longident.Lident "false"), None);
+  pexp_loc        = Location.none;
+  pexp_attributes = [];
+}
+
+(* dummy_assertfalse : expression *)
+let dummy_assertfalse = {
+  pexp_desc       = Pexp_assert (dummy_false);
+  pexp_loc        = Location.none;
+  pexp_attributes = [];
+}
+
+(* 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
+
+(* find_funtype_args : typ list -> int -> (int, typ) 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 (_) -> []
+
+(* 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 * 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 ("", 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 =
+  (* Format.fprintf ppf "@[%a@]@." Pprintast.structure structure; *)
+  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, prefix) =
+  is_well_typed_structure (plug_str (expr, cxt)) env
+
+(********** get **********)
+
+(* get_from_strcxt を使うと、以前の定義に飛んでいけるが、
+ * toplevel で使っていると、表示は変になる。以前の定義を示して、
+ * そこにアンダーラインを引くのは難しいかも。
+ *)
+
+(*
+(* get_from_strcxt : string -> str_context -> expression context_t option *)
+let rec get_from_strcxt st prefix = match prefix with
+    [] -> (* This happens when no binding is found, such as for '+' *)
+      None
+  | ({ pstr_desc = Pstr_value (flg, bindings) }, env) :: rest ->
+      (* let 文のみ考慮 *)
+      let rec loop bindings' = match bindings' with
+          [] -> get_from_strcxt 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
+                Some ((e, cxt'), env, prefix)
+              else Some ((e, Empty), env, rest)
+            else loop rest'
+      in loop bindings
+  | _ :: rest -> (* モジュール等は今のところ無視されている *)
+      get_from_strcxt st rest
+
+(* get : string context_t -> expression context_t option *)
+let rec get ((st, cxt), env, prefix) = match cxt with
+    Empty -> get_from_strcxt st prefix
+  | Lambda (p, cxt') -> (* もし p に現れていたら、その変数の定義はない *)
+      if pat_appears st p then None else get ((st, cxt'), env, prefix)
+  | Let (flg, bindings, cxt') ->
+      let rec loop bindings' = match bindings' with
+          [] -> get ((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
+                Some ((e, cxt''), env, prefix)
+              else Some ((e, cxt'), env, prefix)
+            else loop rest
+      in loop bindings
+*)
+
+(* 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 : Longident.t context_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 (env', prefix') -> get_var_from_prefix st prefix'
+      end
+  | Longident.Lapply (_, _) ->
+      failwith "TypeDebugger: Longident.Lapply in get"
+
+(********** pattern **********)
+
+(* 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 (_) -> []
+
+(********** decompose **********)
+
+(* three phases of decompose *)
+(* 名前、要変更 *)
+type decompose_phase_t =
+    Illtyped (* decompose する式には型がつかない *)
+(*
+  | Typed_fv (* 型はついていて、自由変数が意図に合っているかを確かめている *)
+*)
+  | Typed    (* 型はついていて、その型が意図に合っているかを確かめている *)
+
+(* 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} ->
+      [((exp, Lambda (pat, cxt)), env, prefix)]
+  | {pc_lhs = pat; pc_guard = Some (g); pc_rhs = exp} ->
+      [((g, cxt), env, prefix); ((exp, Lambda (pat, 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_fv -> [] *)
+         | Typed -> get ((longident, cxt), env, prefix)
+             (*
+            begin match lloc with
+                {txt = Longident.Lident (st)} ->
+                  begin match get ((st, cxt), env, prefix) with
+                      None -> []
+                    | Some ((exp', cxt'), env', prefix') ->
+                        [((exp', cxt'), env', prefix')]
+                  end
+              | {txt = Longident.Ldot (t, st)} -> []
+                  (* List.map など。対応の必要あり *)
+              | {txt = Longident.Lapply (t1, t2)} ->
+                  failwith "TypeDebugger: Longident.Lapply in decompose_expr"
+            end
+       *)
+       end
+   | Parsetree.Pexp_constant (c) -> []
+   | Parsetree.Pexp_let (rec_flg, bindings, exp) -> begin match phase with
+(* ------------------------------------------------------------------------ *)
+  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_assertfalse})
+                                  bindings in
+         List.map (fun {pvb_expr = exp} -> ((exp, cxt'), env, prefix)) bindings
+         @ [((exp, Let (rec_flg, bindings', cxt)), env, prefix)]
+    else List.map (fun {pvb_expr = exp} -> ((exp, cxt), env, prefix)) bindings
+         @ [((exp, 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_function (lbl, exp_op, patexps) ->
+       (match exp_op with
+           None -> decompose_expand_patexps ((patexps, cxt), env, prefix)
+         | Some (exp) ->
+             ((exp, cxt), env, prefix) ::
+               decompose_expand_patexps ((patexps, cxt), env, prefix))
+       (* パターンは、常に cxt に入れて構わない *)
+       (* それが問題でも、exps の中で顕在化するので *)
+       (* と、思ったが、それは exp に型がついている場合 *)
+       (* 型がついていないときは、パターンの制約が conflict しているかも *)
+       (* パターンは常に展開して、fun が原因と特定されたら、パターンを *)
+       (* 原因と特定する方針に変更 *)
+
+       (* 上記は、今ひとつ理解不能だが *)
+       (* let (a, b) : int = 3 *)
+       (* とかの場合か *)
+*)
+   | Parsetree.Pexp_fun (lbl, None, pat, exp) ->
+       [((exp, Lambda (pat, cxt)), env, prefix)]
+   | Parsetree.Pexp_fun (lbl, Some (exp1), pat, exp) ->
+       [((exp1, cxt), env, prefix);
+        ((exp, Lambda (pat, 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 (lloc, None) -> []
+   | Parsetree.Pexp_construct (lloc, Some ({pexp_desc = Pexp_tuple (exps)})) ->
+       (* :: など infix の構成子だと組をハイライトできないため *)
+       List.map (fun exp -> ((exp, cxt), env, prefix)) exps 
+   | Parsetree.Pexp_construct (lloc, Some (exp)) ->
+       [((exp, cxt), env, prefix)]
+   | Parsetree.Pexp_variant (l, None) -> []
+   | Parsetree.Pexp_variant (l, Some (exp)) ->
+       [((exp, cxt), env, prefix)]
+   | Parsetree.Pexp_record (lexps, None) ->
+       List.map (fun (l, exp) -> ((exp, cxt), env, prefix)) lexps
+   | Parsetree.Pexp_record (lexps, Some (exp)) ->
+       ((exp, cxt), env, prefix) ::
+       List.map (fun (l, exp) -> ((exp, cxt), env, prefix)) lexps
+   | Parsetree.Pexp_field (exp, lloc) ->
+       [((exp, cxt), env, prefix)]
+   | Parsetree.Pexp_setfield (exp1, lloc, 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_for (stloc, exp1, exp2, _, exp3) ->
+       (* for is a binder.  Have to deal with it. *)
+       [((exp1, cxt), env, prefix); ((exp2, cxt), env, prefix);
+        ((exp3, cxt), env, prefix)]
+*)
+(*
+   | Parsetree.Pexp_constraint (exp, op1, op2) ->
+      (* TODO : other argument *)
+      (* [(prefix, (cxt, exp))] *)
+      (match (op1, op2) with
+            (None, None) -> Format.fprintf (Format.std_formatter) "None, None@\n"
+          | (Some (t1), None) -> Format.fprintf(Format.std_formatter) "Some None@\n";
+                                 (match t1.ptyp_desc with
+                                    Ptyp_any -> ()
+                                  | Ptyp_var (s) -> 
+                                     Format.fprintf (Format.std_formatter) "Ptyp.var %s@\n" s
+                                  | Ptyp_arrow (l, c1, c2) -> ()
+                                  | Ptyp_tuple (clist) -> ()
+                                  | Ptyp_constr (sloc, lst) -> 
+                                     (match sloc with
+                                        {txt = Longident.Lident(s)} -> Format.fprintf (Format.std_formatter) "Ptyp.constr %s@\n" s
+                                       | _ -> Format.fprintf (Format.std_formatter) "Ptyp.constr: not Lident@\n")
+                                  (* | Ptyp_constr (_, lst) -> () *)
+                                  | _ -> ())
+          (*
+                 | Ptyp_object of core_field_type list
+                 | Ptyp_class of Longident.t * core_type list * label list
+                 | Ptyp_alias of core_type * string
+                 | Ptyp_variant of row_field list * bool * label list option
+                 | Ptyp_poly of string list * core_type
+                 | Ptyp_package of package_type
+           *)
+          (* ); *)
+          (*Printtyp.type_expr t1*)
+          | (None, Some (t2)) -> Format.fprintf(Format.std_formatter) "None Some@\n"
+          (*Printtyp.type_expr t2*)
+          |(Some (t1), Some (t2)) -> 
+            Format.fprintf(Format.std_formatter) "Some Some@\n"
+      (*Printtyp.type_expr t1
+               Printtyp.type_expr t2 *) );
+      decompose_expr ((exp, cxt), env, prefix) phase
+   | Parsetree.Pexp_when (exp1, exp2) ->
+      [((exp1, cxt), env, prefix); ((exp2, cxt), env, prefix)]
+*)
+   | Parsetree.Pexp_send (exp, st) ->
+       [((exp, cxt), env, prefix)]
+(*
+   | Parsetree.Pexp_new (lloc) -> []
+       (* let (str, _ ) = cxt in
+          List.flatten (search_class (List.rev str) l cxt) *)
+*)
+   | Parsetree.Pexp_setinstvar (stloc, exp) ->
+       [((exp, cxt), env, prefix)]
+(*
+   | Parsetree.Pexp_override (stlocexps) ->
+      let stexps = List.map (fun x -> match x with ({txt = s}, e) -> (s, e)) stlocexps in
+       List.map (fun (st, exp) -> ((exp, cxt), env, prefix)) stexps
+   | Parsetree.Pexp_letmodule (stloc, _, exp) ->
+       (* [(prefix, (cxt, exp))] *)
+       decompose_expr ((exp, cxt), env, prefix) phase
+*)
+   | Parsetree.Pexp_assert (exp) ->
+       [((exp, cxt), env, prefix)]
+   | Parsetree.Pexp_lazy (exp) ->
+       [((exp, cxt), env, prefix)]
+(*
+   | Parsetree.Pexp_poly (exp, _)->
+       (* [(prefix, (cxt, exp))] *)
+       decompose_expr ((exp, cxt), env, prefix) phase
+   | Parsetree.Pexp_object (class_structure) -> []
+       (* let cxt' = addcxt_str cxt (fun cxt -> Lambda (pat, cxt)) in
+          decompose_class cxt' class_structure *)
+   | Parsetree.Pexp_newtype (st, exp) ->
+       (* [(prefix, (cxt, exp))] *)
+       decompose_expr ((exp, cxt), env, prefix) phase
+   | Parsetree.Pexp_pack (module_expr) -> []
+*)
+   | Parsetree.Pexp_open (flag, stloc, exp) ->
+       [((exp, cxt), env, prefix)]
+(*
+   | Parsetree.Pexp_extension (ext) -> []
+*)
+   | _ ->
+       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) 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
+
+(* 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 }, _)} :: [] ->
+      (* Format.fprintf ppf "exp:@.%a@." Pprintast.expression expr; *)
+      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 **********)
+
+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, cxt), env, prefix) =
+  print_loc pat.ppat_loc;
+  print_identified ();
+  print_pattern ()
+
+(* make_message_recursive1 : value_binding list 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 ("", 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 ("", 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],
+                                                dummy_assertfalse);
+                     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 (c) } -> (* 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
+
+(* 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 -> yes_no_list -> yes_no_list ->
+                           unit *)
+let make_message_illtyped ((expr, cxt), env, prefix) yes no =
+  match expr.pexp_desc with 
+    Parsetree.Pexp_ident (lloc) ->
+      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 (l, e) -> snd (judge ((e, cxt), env, prefix)))
+                          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, t2) -> (* 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 typs t1 exp
+        end
+
+  | Parsetree.Pexp_function (cases) ->
+      print_illtyped_function ()
+
+  | Parsetree.Pexp_fun (lbl, exp_op, pat, exp) ->
+      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 = dummy_assertfalse})
+                 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 = dummy_assertfalse})
+                 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, t2) ->
+                      (* 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, ok2), Some (notok1, notok2)) ->
+                      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
+              | _ :: _ -> (* 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;
+      (* exp の型 *)
+      let (_, exp_typ) = judge ((exp, cxt), env, prefix) in
+      (* cases をひとつずつ加えて、型がつかなくなるところを探す *)
+      (* 型エラーを起こさない cases の列と
+       * 型エラーを起こす最初の case のペアを返す *)
+      let rec well_typed_cases wcases cases = match cases with
+          [] -> None (* すべての 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 well_typed_cases wcases' rest
+            else Some (wcases, case) in
+      (* body と guard を無効にした cases *)
+      let pattern_only_cases =
+        List.map (fun {pc_lhs = pat} ->
+                    {pc_lhs = pat; pc_guard = None; pc_rhs = dummy_assertfalse})
+                 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 = dummy_assertfalse})
+                 cases in
+      begin match well_typed_cases [] pattern_only_cases with
+        Some ([], case) -> (* exp と最初の pattern が合わない *)
+          let case' = Exp.mk (Pexp_function ([case])) in
+          if debug land 8 = 8 then
+            Format.fprintf ppf "message illtyped match2:@.%a@."
+              Pprintast.expression case';
+          (* 最初のパターンの型 *)
+          let (_, pat_typ) = judge ((case', cxt), env, prefix) in
+          begin match split_arrow pat_typ with
+            Some (t1, t2) ->
+              print_loc expr.pexp_loc;
+              print_identified ();
+              print_illtyped_match_exp exp_typ t1
+          | None -> (* Can't happen *)
+              failwith "TypeDebugger: match1 in make_message_illtyped."
+          end
+      | Some (wcases, case) -> (* pattern 同士で合わないところがある *)
+          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, ok2), Some (notok1, notok2)) ->
+              print_loc case.pc_lhs.ppat_loc;
+              print_identified ();
+              print_illtyped_match_left notok1 ok1
+          | (_, _) -> (* Can't happen *)
+              failwith "TypeDebugger: match2 in make_message_illtyped."
+          end
+      | None -> (* pattern は型が合っている *)
+          (* guard を調べる。guard は exp を assert false にして *)
+          (* 調べるべき（環境の衝突を避けるため）。また、bool に *)
+          (* annotation を付けて調べるべき *)
+          begin match well_typed_cases [] pattern_and_guard_cases with
+            Some (wcases, {pc_guard = None}) -> (* Can't happen *)
+              failwith "TypeDebugger: match3 in make_message_illtyped."
+          | Some (wcases, {pc_guard = Some (g)}) -> (* guard が原因 *)
+              print_loc g.pexp_loc;
+              print_identified ();
+              print_guard ()
+          | None -> (* guard も型が合っている *)
+              begin match well_typed_cases [] cases with
+                Some ([], case) -> (* case がひとつ目からだめ *)
+                  (* exp と case で環境が conflict している *)
+                  print_loc expr.pexp_loc;
+                  print_identified ();
+                  print_illtyped_other () (* メッセージを変えるべき *)
+              | Some (wcases, case) -> (* case の右辺の式が原因 *)
+                  let wcases' = Exp.mk (Pexp_match (exp, wcases)) in
+                  if debug land 8 = 8 then
+                    Format.fprintf ppf "message illtyped match4:@.%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 match5:@.%a@."
+                      Pprintast.expression case';
+                  (* 型が合わない case の型 *)
+                  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
+              | None -> (* Can't happen *) (* guard も型が合っている *)
+                  failwith "TypeDebugger: match4 in make_message_illtyped."
+              end
+          end
+      end
+*)
+
+  | Parsetree.Pexp_construct (l, Some (exp)) ->
+      (* Location があるはずなのでもっと拡張できそう *)
+      print_loc expr.pexp_loc;
+      print_identified ();
+      print_illtyped_constructor ()
+
+  | _ -> (* 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
+  (*
+  let no' = clean_yes_no_list no in
+  let vartyps' = List.filter (fun (key, typ) -> answered_no key typ no' env)
+                             vartyps in
+*)
+  match expr.pexp_desc with 
+(*
+   | Parsetree.Pexp_ifthenelse (exp1, exp2, None) ->
+      (* 1. exp1 を no と言っていたら*)
+      (* exp1 に bool annotation を付ける *)
+      let lidentloc = {txt = Longident.Lident ("bool"); loc = Location.none} in
+      let exp1' = { pexp_desc = Pexp_constraint 
+                                  (exp1, Some({ ptyp_desc = Ptyp_constr (lidentloc, []);
+                                                ptyp_loc = Location.none }), None); 
+                    pexp_loc = Location.none } in
+      let (bool_env, typ) = judge ((exp1', cxt), env, prefix) in
+      let conf_list = search_conflict_env bool_env env vartyps' [] in
+      (match conf_list with
+         [] -> (* exp1 は bool と意図されている *)
+         (* 2. exp2 に unit annotation を付ける *)
+         let lidentloc2 = {txt = Longident.Lident ("unit"); loc = Location.none} in
+         let exp2' = { pexp_desc = Pexp_constraint 
+                                     (exp2, Some({ ptyp_desc = Ptyp_constr (lidentloc2, []);
+                                                   ptyp_loc = Location.none }), None); 
+                       pexp_loc = Location.none } in
+         let (unit_env, typ) = judge ((exp2', cxt), env, prefix) in
+         let conf_list = search_conflict_env unit_env env vartyps' [] in
+         (match conf_list with
+            [] ->   print_loc expr.pexp_loc;
+                    print_identified ();
+                    print_welltyped_expr t (* exp2 は unit と意図されている -> 部分プログラムは意図通り *)
+          | (((st, _), _, _), typ) :: rest -> 
+             print_loc exp2.pexp_loc;
+             print_identified ();
+             print_welltyped_if_unit st typ rest (* unit と意図されていない *)
+         )
+       | (((st, _), _, _), typ) :: rest -> 
+          print_loc exp1.pexp_loc;
+          print_identified ();
+          print_welltyped_if_bool st typ rest (* bool と意図されていない *)
+      )
+   | Parsetree.Pexp_ifthenelse (exp1, exp2, Some (exp3)) ->
+      (* 1. exp1 を no と言っていたら*)
+      (* exp1 に bool annotation を付ける *)
+      let lidentloc = {txt = Longident.Lident ("bool"); loc = Location.none} in
+      let exp1' = { pexp_desc = Pexp_constraint 
+                                  (exp1, Some({ ptyp_desc = Ptyp_constr (lidentloc, []);
+                                                ptyp_loc = Location.none }), None); 
+                    pexp_loc = Location.none } in
+      let (bool_env, typ) = judge ((exp1', cxt), env, prefix) in
+      let conf_list = search_conflict_env bool_env env vartyps' [] in
+      (match conf_list with
+         [] -> (* exp1 は bool と意図されている *)
+         (* 2. exp2 と exp3 の型が同じかを見る *)
+       (* exp2 と exp3 を同じリストに入れる *)
+         let mtloc = {txt = Longident.Lident ("[]"); loc = Location.none} in 
+         let mt = { pexp_desc = Pexp_construct (mtloc,
+                                               None,
+                                               false);
+                   pexp_loc = Location.none } in
+         let exploc = {txt = Longident.Lident ("::"); loc = Location.none} in 
+         let exp3' = { pexp_desc = Pexp_construct (exploc,
+                                                   Some ({ pexp_desc = Pexp_tuple [exp3; mt]; 
+                                                           pexp_loc = Location.none }),
+                                                   false);
+                       pexp_loc = Location.none } in
+         let exp' = { pexp_desc = Pexp_construct(exploc,
+                                                 Some ({ pexp_desc = Pexp_tuple [exp2; exp3']; 
+                                                         pexp_loc = Location.none }),
+                                                 false);
+                      pexp_loc = Location.none } in
+        let (lst_env, typ) = judge ((exp', cxt), env, prefix) in
+        let conf_list = search_conflict_env lst_env env vartyps' [] in
+        (match conf_list with
+           [] -> 
+           print_loc expr.pexp_loc;
+           print_identified ();
+           print_welltyped_expr t (* exp2, exp3 は同じ型と意図している -> 部分プログラムは意図通り *)
+         | (((st, _), _, _), typ) ::rest -> 
+            print_loc expr.pexp_loc;
+            print_identified ();
+            print_welltyped_if_then_else st typ rest (* exp2, exp3 を同じ型と意図していない *)
+        )
+       | (((st, _), _, _), typ) :: rest -> 
+          print_loc exp1.pexp_loc;
+          print_identified ();
+          print_welltyped_if_bool st typ rest (* bool と意図されていない *)
+      )
+   | Parsetree.Pexp_match (exp, patexps) ->
+      (* TODO : exp と pattern が違っている場合がない *)
+      let dummy_match = make_pattern_match expr in (* expression を dummy にする *)
+   (* pattern が意図通りかを調べる *)
+      let (pat_env, typ) = judge((dummy_match, cxt), env, prefix) in
+      let conf_list = search_conflict_env pat_env env vartyps' [] in
+      (match conf_list with
+         [] -> (* pattern は ok, expression が意図通りでない *)
+         let (exp_env, typ) = judge((expr, cxt), env, prefix) in (* vartyps でいい気がする *)
+         (* conf_list2 = vartyps' …? 以下の作業いらない…? *)
+         let conf_list2 = search_conflict_env exp_env env vartyps' [] in
+         (match conf_list2 with
+            [] -> (* expression も意図通り -> 部分プログラムは意図通り *)
+            print_loc expr.pexp_loc;
+            print_identified ();
+            print_welltyped_expr t
+          | (((st, _), _, _), typ) :: rest -> 
+             print_loc expr.pexp_loc;
+             print_identified ();
+             print_welltyped_match_expression st typ rest )
+       | (((st, _), _, _), typ) ::rest -> (* pattern が意図通りでない *)
+          print_loc expr.pexp_loc;
+          print_identified ();
+          print_welltyped_match_pattern st typ rest )
+*)
+   | _ ->
+       print_loc expr.pexp_loc;
+       print_identified ();
+       begin match vartyps' with
+           [] -> (* 自由変数は意図通り *)
+             print_welltyped_expr t
+         | (((st, _), _, _), typ) :: [] -> (* 自由変数が意図通りでない *)
+             print_welltyped_env1 st typ
+         | (((st, _), _, _), typ) :: rest ->
+             print_welltyped_env_many st typ rest
+       end
+
+(********** ask questions **********)
+
+(* 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 -> unit *)
+let ask_expr_helper expr t env yes no =
+  if Ctype.moregeneral env false t (Btype.newgenvar ())
+  then (true, yes, no)
+  else begin
+    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, cxt), env, prefix) t env yes no =
+  ask_expr_helper expr t env yes no
+  (*
+  match expr.pexp_desc with
+    Pexp_ident ({txt = Longident.Lident (st)}) ->
+      (* 変数の場合。以前の返答を利用する *)
+      (* が、以下ではまだ利用できていない。get に登録されているのは *)
+      (* let で束縛されたもののみで、パターン変数は入っていないから *)
+      (* パターン変数も入れて、それを定義とすべきか *)
+      begin match get ((st, cxt), env, prefix) with
+          None -> (* + など *)
+            ask_expr_helper expr t env yes no
+        | Some (key) ->
+            if answered_yes ((st, cxt), env, prefix) t yes env then
+              (true, yes, no)
+            else if answered_no ((st, cxt), env, prefix) t no env then
+              (false, yes, no)
+            else ask_expr_helper expr t env yes no
+      end
+  | _ -> (* 変数以外の場合 *)
+      ask_expr_helper expr t env yes no
+      *)
+
+(********** check whether expr has intended type **********)
+
+(* 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 **********)
+
+(* 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 ->
+      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 context_t list -> pattern option *)
+let rec walk_right_illtyped_pattern ((pats, cxt), env, prefix) = match pats with
+    [] -> None
+  | pat :: rest ->
+      let exp = Exp.mk (Pexp_fun ("", None, pat, dummy_assertfalse)) 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 -> pattern option *)
+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;
+              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, dummy_assertfalse)) 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)
+    | _ -> (* let 文以外の式 *)
+        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
+
+(********** 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, dummy_assertfalse);
+         pexp_loc        = loc;
+         pexp_attributes = [] }, Empty)
+  | _ -> failwith "TypeDebugger: Error: this structure not supported."
+
+(* illtyped_exp : 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 *)
+         -> (expr_of_structure s, env, lst)  
+      end
+
+(********** main entry point **********)
+
+(* algo : toplevel_phrase -> Env.t -> unit *)
+(* called form the compiler *)
+(* phr contains all the program to be compiled *)
+(* toplevel_env is always the clean initial environment *)
+let algo phr toplevel_env =
+  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;
+      begin try
+        (* go into the illtyped structure *)
+        walk_up_illtyped ((expr, cxt), env, prefix) [] []
+      with
+        DebuggerQuit -> ()
+      end
+
+let rec rev_flatten structures acc = match structures with
+    [] -> acc
+  | structure :: rest -> rev_flatten rest (structure @ acc)
+
+(* algo2 : toplevel_phrase -> structure list -> Env.t -> unit *)
+(* called from the top level *)
+(* phr contains the latest phrase input by the user *)
+(* rev_structures contains the phrase input so far in the reverse order *)
+(* toplevel_env is always the clean initial environment *)
+let algo2 phr rev_structures toplevel_env = match phr with
+    Ptop_dir (_, _) ->
+      failwith "TypeDebugger: Error: Ptop_dir is passed to algo2."
+  | Ptop_def (structure) ->
+      let structure = rev_flatten (structure :: rev_structures) [] in
+      algo (Ptop_def (structure)) toplevel_env
+
+end (***** end of module *)
+
+let algo phr toplevel_env = A.algo phr toplevel_env
+
+let algo2 structure rev_structures toplevel_env =
+  A.algo2 structure rev_structures toplevel_env
diff -urN ocaml-4.02.1-org/typing/debug_message.ml ocaml-4.02.1/typing/debug_message.ml
--- ocaml-4.02.1-org/typing/debug_message.ml	1970-01-01 09:00:00.000000000 +0900
+++ ocaml-4.02.1/typing/debug_message.ml	2015-05-14 11:39:51.000000000 +0900
@@ -0,0 +1,545 @@
+open Format
+
+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" ||
+     String.sub lang 0 (min 5 (String.length lang)) = "en_US.ISO8859-1"
+  then Japanese
+  else English
+with Not_found -> English
+
+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 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 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;
+  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
+
+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 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
+
+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 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
+
+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
+
+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
+
+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 print_illtyped_constructor () =
+  match language with
+| English -> fprintf ppf
+    "@[Error25 : The constructor is given a wrong type of argument(s).@]@."
+| Japanese -> fprintf ppf
+    "@[Error25 : コンストラクタの引数の型が合っていません。@]@."
+
+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 *)
