(***********************************************************************)
(*                                                                     *)
(*                           Ocamlexc                                  *)
(*                                                                     *)
           , projet Cristal , INRIA Rocquencourt         
(*                                                                     *)
   Copyright 1998 Institut National de Recherche en Informatique et   
   Automatique .   Distributed only by permission .                      
(*                                                                     *)
(***********************************************************************)




open Format ;;


(* Bool telling if we must load pervasives in standard or not *)
let std_perv = ref true ;;



(* Main loop *)
let main filename =
  Files.current_comp_unit := Files.module_name_from_ml_filename filename ;
  let channel = open_in filename in
  let lexbuf = Lexing.from_channel channel in
   try
  First , load Pervasives if not compiling the Pervasives module
    (* or if pervasives are not wanted.                              *)
    if Filename.basename filename <> "pervasives.ml" && !std_perv then
     begin
     Envscope.global_scope_env :=
       Envscope.handle_open_directive
                 !Envscope.global_scope_env
                 (Path.Pident (Ident.create_global "Pervasives")) ;
     Inputpt.load [Ident.create_global "Pervasives"]
     end ;
    (* Now parse the file *)
    let structure = Parse.implementation lexbuf in
    (* Extend handlers *)
    let extended_structure =
               Extendhandler.extend_structure_handler structure in
    (* Only scope the module *)
    let (scoped_structure, new_scenv) = Modscope.scope_structure
				                !Envscope.global_scope_env
					        extended_structure in
    (* Load external signatures found during scoping.            *)
    (* This update the global typing environment by side effect. *)
    Inputpt.load (Envscope.get_compil_units_to_load ()) ;
    (* Now let's type... *)
    let (typed_structure, struct_signature) = Infermod.infer_structure
                                                      !Envtype.global_type_env
                                                      scoped_structure in
    (* Change all uses of types in this module by prefixing them   *)
    (* with their full path, i.e the module name that will be      *)
    (* generated by considering this compilation unit as a module. *)
    Infermod.prefix_structure
          (Path.Pident (Ident.create_global !Files.current_comp_unit))
          typed_structure ;
    (* Retrieve scoping information for the interior of the module *)
    let mod_scope_info = Envscope.diff new_scenv !Envscope.global_scope_env in
    (* Generate the persistent file containing the result of the analysis. *)
    Outputp.output filename mod_scope_info struct_signature typed_structure
   with
    | End_of_file -> close_in channel ; exit 0
    | Lexer.Error (err, start, stop) ->
	Error.handle_lexing_error err start stop ; exit 2
    | Syntaxerr.Error err ->
	Error.handle_parsing_error err ; exit 2
    | Envscope.Scope_error err ->
	Error.handle_scoping_error err ; exit 2
    | Typecore.Conflict (ty0, ty1) ->
	Error.handle_unification_error ty0 ty1 ; exit 2
    | Typecore.Non_regular_datatype (ty0, ty1) ->
	Error.handle_circularization_error ty0 ty1
    | Envtype.Type_error err ->
	Error.handle_typing_error err ; exit 2
    | Infercore.Constructor_arity_error path ->
	fprintf std_formatter "Invalid arity for constructor '%a' use\n"
	        Path.pp_path path ;
	exit 2
    | Infercore.Unbound_type_variable var_name ->
	fprintf std_formatter "Unbound type variable %s\n" var_name ; exit 2
    | Infercore.Type_arity_error path ->
	fprintf std_formatter "Bad arity for type %a use\n" Path.pp_path path ;
	exit 2
    | Infercore.Bad_labels_number ->
	fprintf std_formatter "Bad # of labels in record\n" ; exit 2
    | Infercore.Field_not_mutable lbl_path ->
	fprintf std_formatter "Label %a is not mutable\n"
	          Path.pp_path lbl_path ;
	exit 2
    | Substract.Unused_pattern ->
	fprintf std_formatter "A pattern is unused.\n" ; exit 2
    | Corescope.Or_pattern_must_not_bind ->
	fprintf std_formatter "Or patterns must not bind variables.\n" ; exit 2
    | Infercore.Expansion_required_in_primitive path ->
	fprintf std_formatter "Please expand beforehand abbreviation for type '%a' in external definition\n" Path.pp_path path ;
	exit 2
    | Infercore.Invalid_equiv_in_variant_type ->
	fprintf std_formatter "Invalid type equivalence in manifest sum\n" ;
	exit 2
;;




(* Let's run... *)
let filename = ref None ;;
Arg.parse
  [ ("-I", Arg.String
             (fun path ->
               let path = path ^ "/" in
               Stdlibpath.std_lib_path := path :: !Stdlibpath.std_lib_path),
           "Path to stdlib") ;
    ("-noperv", Arg.Unit (fun () -> std_perv := false), "Disable pervs") ]
          (fun fname ->
            if not ((Filename.check_suffix fname ".ml")
		    || (Filename.check_suffix fname ".mli")) then
	     begin
             fprintf std_formatter "Invalid filename (.ml(i) missing)\n" ;
             exit 0
             end ;
            filename := Some fname)
    "Ocamlexc 1.0.1 - Uncaught exceptions analyser - First pass" ;;
Envscope.load_scopes () ;;
Envtype.load_types () ;;
Stdlibpath.std_lib_path := List.rev ("./" :: !Stdlibpath.std_lib_path) ;;
let _ =
 match !filename with
  | None -> ()
  | Some fname -> main fname
;;

*********************************************************************
                                                                     
                           Ocamlexc                                  
                                                                     
                                                                     
                                                                     
*********************************************************************
 Bool telling if we must load pervasives in standard or not 
 Main loop 
 or if pervasives are not wanted.                              
 Now parse the file 
 Extend handlers 
 Only scope the module 
 Load external signatures found during scoping.            
 This update the global typing environment by side effect. 
 Now let's type... 
 Change all uses of types in this module by prefixing them   
 with their full path, i.e the module name that will be      
 generated by considering this compilation unit as a module. 
 Retrieve scoping information for the interior of the module 
 Generate the persistent file containing the result of the analysis. 
 Let's run... 
           , projet Cristal , INRIA Rocquencourt         
   Copyright 1998 Institut National de Recherche en Informatique et   
   Automatique .   Distributed only by permission .                      




open Format ;;


let std_perv = ref true ;;



let main filename =
  Files.current_comp_unit := Files.module_name_from_ml_filename filename ;
  let channel = open_in filename in
  let lexbuf = Lexing.from_channel channel in
   try
  First , load Pervasives if not compiling the Pervasives module
    if Filename.basename filename <> "pervasives.ml" && !std_perv then
     begin
     Envscope.global_scope_env :=
       Envscope.handle_open_directive
                 !Envscope.global_scope_env
                 (Path.Pident (Ident.create_global "Pervasives")) ;
     Inputpt.load [Ident.create_global "Pervasives"]
     end ;
    let structure = Parse.implementation lexbuf in
    let extended_structure =
               Extendhandler.extend_structure_handler structure in
    let (scoped_structure, new_scenv) = Modscope.scope_structure
				                !Envscope.global_scope_env
					        extended_structure in
    Inputpt.load (Envscope.get_compil_units_to_load ()) ;
    let (typed_structure, struct_signature) = Infermod.infer_structure
                                                      !Envtype.global_type_env
                                                      scoped_structure in
    Infermod.prefix_structure
          (Path.Pident (Ident.create_global !Files.current_comp_unit))
          typed_structure ;
    let mod_scope_info = Envscope.diff new_scenv !Envscope.global_scope_env in
    Outputp.output filename mod_scope_info struct_signature typed_structure
   with
    | End_of_file -> close_in channel ; exit 0
    | Lexer.Error (err, start, stop) ->
	Error.handle_lexing_error err start stop ; exit 2
    | Syntaxerr.Error err ->
	Error.handle_parsing_error err ; exit 2
    | Envscope.Scope_error err ->
	Error.handle_scoping_error err ; exit 2
    | Typecore.Conflict (ty0, ty1) ->
	Error.handle_unification_error ty0 ty1 ; exit 2
    | Typecore.Non_regular_datatype (ty0, ty1) ->
	Error.handle_circularization_error ty0 ty1
    | Envtype.Type_error err ->
	Error.handle_typing_error err ; exit 2
    | Infercore.Constructor_arity_error path ->
	fprintf std_formatter "Invalid arity for constructor '%a' use\n"
	        Path.pp_path path ;
	exit 2
    | Infercore.Unbound_type_variable var_name ->
	fprintf std_formatter "Unbound type variable %s\n" var_name ; exit 2
    | Infercore.Type_arity_error path ->
	fprintf std_formatter "Bad arity for type %a use\n" Path.pp_path path ;
	exit 2
    | Infercore.Bad_labels_number ->
	fprintf std_formatter "Bad # of labels in record\n" ; exit 2
    | Infercore.Field_not_mutable lbl_path ->
	fprintf std_formatter "Label %a is not mutable\n"
	          Path.pp_path lbl_path ;
	exit 2
    | Substract.Unused_pattern ->
	fprintf std_formatter "A pattern is unused.\n" ; exit 2
    | Corescope.Or_pattern_must_not_bind ->
	fprintf std_formatter "Or patterns must not bind variables.\n" ; exit 2
    | Infercore.Expansion_required_in_primitive path ->
	fprintf std_formatter "Please expand beforehand abbreviation for type '%a' in external definition\n" Path.pp_path path ;
	exit 2
    | Infercore.Invalid_equiv_in_variant_type ->
	fprintf std_formatter "Invalid type equivalence in manifest sum\n" ;
	exit 2
;;




let filename = ref None ;;
Arg.parse
  [ ("-I", Arg.String
             (fun path ->
               let path = path ^ "/" in
               Stdlibpath.std_lib_path := path :: !Stdlibpath.std_lib_path),
           "Path to stdlib") ;
    ("-noperv", Arg.Unit (fun () -> std_perv := false), "Disable pervs") ]
          (fun fname ->
            if not ((Filename.check_suffix fname ".ml")
		    || (Filename.check_suffix fname ".mli")) then
	     begin
             fprintf std_formatter "Invalid filename (.ml(i) missing)\n" ;
             exit 0
             end ;
            filename := Some fname)
    "Ocamlexc 1.0.1 - Uncaught exceptions analyser - First pass" ;;
Envscope.load_scopes () ;;
Envtype.load_types () ;;
Stdlibpath.std_lib_path := List.rev ("./" :: !Stdlibpath.std_lib_path) ;;
let _ =
 match !filename with
  | None -> ()
  | Some fname -> main fname
;;
