parse_type.ml 7.83 KB
Newer Older
charguer's avatar
init  
charguer committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64
open Config
open Clflags
open Misc
open Format
open Typedtree

(** The purpose of this file is to parse an interface file.
    The content of this file is a copy-pasting from the source
    code of OCamldoc. *)

(*#########################################################################*)
(* ** Parsing of MLI files *)

(** Initialize the search path.
   The current directory is always searched first,
   then the directories specified with the -I option (in command-line order),
   then the standard library directory. *)

let init_path () =
  load_path :=
    "" :: List.rev (Config.standard_library :: !Clflags.include_dirs);
  Env.reset_cache ()

(** Return the initial environment in which compilation proceeds. *)
let initial_env () =
  try
    if !Clflags.nopervasives
    then Env.initial
    else Env.open_pers_signature "Pervasives" Env.initial
  with Not_found ->
    fatal_error "cannot open pervasives.cmj"

(** Optionally preprocess a source file *)
let preprocess sourcefile =
  match !Clflags.preprocessor with
    None -> sourcefile
  | Some pp ->
      let tmpfile = Filename.temp_file "camlpp" "" in
      let comm = Printf.sprintf "%s %s > %s" pp sourcefile tmpfile in
      if Ccomp.command comm <> 0 then begin
        remove_file tmpfile;
        Printf.eprintf "Preprocessing error\n";
        exit 2
      end;
      tmpfile

(** Remove the input file if this file was the result of a preprocessing.*)
let remove_preprocessed inputfile =
  match !Clflags.preprocessor with
    None -> ()
  | Some _ -> remove_file inputfile

let remove_preprocessed_if_ast inputfile =
  match !Clflags.preprocessor with
    None -> ()
  | Some _ -> if inputfile <> !Location.input_name then remove_file inputfile

exception Outdated_version

(** Parse a file or get a dumped syntax tree in it *)
let parse_file inputfile parse_fun ast_magic =
  let ic = open_in_bin inputfile in
  let is_ast_file =
    try
65 66 67
      let buffer =
        really_input_string ic (String.length ast_magic)
      in
charguer's avatar
init  
charguer committed
68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100
      if buffer = ast_magic then true
      else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then
        raise Outdated_version
      else false
    with
      Outdated_version ->
        fatal_error "Ocaml and preprocessor have incompatible versions"
    | _ -> false
  in
  let ast =
    try
      if is_ast_file then begin
        Location.input_name := input_value ic;
        input_value ic
      end else begin
        seek_in ic 0;
        Location.input_name := inputfile;
        let lexbuf = Lexing.from_channel ic in
        Location.init lexbuf inputfile;
        parse_fun lexbuf
      end
    with x -> close_in ic; raise x
  in
  close_in ic;
  ast


(** Analysis of an implementation file. Returns (Some typedtree) if
   no error occured, else None and an error message is printed.*)
let process_implementation_file ppf sourcefile =

  init_path ();
  let prefixname = Filename.chop_extension sourcefile in
charguer's avatar
charguer committed
101
  let modulename = String.capitalize_ascii (Filename.basename prefixname) in
charguer's avatar
init  
charguer committed
102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121
  Env.set_unit_name modulename;
  let inputfile = preprocess sourcefile in
  try
  let env = initial_env () in

    let parsetree = parse_file inputfile Parse.implementation ast_impl_magic_number in
    let typedtree = Typemod.type_implementation sourcefile prefixname modulename env parsetree in
    (Some (parsetree, typedtree), inputfile)
  with
    e ->
      match e with
        Syntaxerr.Error err ->
          fprintf Format.err_formatter "@[%a@]@."
            Syntaxerr.report_error err;
          None, inputfile
      | Failure s ->
          prerr_endline s;
          (*incr Odoc_global.errors ;*)
          None, inputfile
      (* ADDED *)
charguer's avatar
charguer committed
122
      | Env.Error err ->
charguer's avatar
init  
charguer committed
123 124 125
          Env.report_error ppf err;
          print_newline();
          raise e
charguer's avatar
charguer committed
126
      | Typecore.Error (loc,err) ->
charguer's avatar
init  
charguer committed
127 128 129 130
          Location.print_error ppf loc;
          Typecore.report_error ppf err;
          print_newline();
          raise e
charguer's avatar
charguer committed
131
      | Typetexp.Error (loc,err) ->
charguer's avatar
init  
charguer committed
132 133 134 135
          Location.print_error ppf loc;
          Typetexp.report_error ppf err;
          print_newline();
          raise e
charguer's avatar
charguer committed
136
      | Typemod.Error (loc,err) ->
charguer's avatar
init  
charguer committed
137 138 139 140 141 142 143 144 145 146 147 148
          Location.print_error ppf loc;
          Typemod.report_error ppf err;
          print_newline();
          raise e
      | e ->
          raise e

(** Analysis of an interface file. Returns (Some signature) if
   no error occured, else None and an error message is printed.
let process_interface_file ppf sourcefile =
  init_path ();
  let prefixname = Filename.chop_extension sourcefile in
charguer's avatar
charguer committed
149
  let modulename = String.capitalize_ascii (Filename.basename prefixname) in
charguer's avatar
init  
charguer committed
150 151 152 153 154 155 156 157 158
  Env.set_unit_name modulename;
  let inputfile = preprocess sourcefile in
  let ast = parse_file inputfile Parse.interface ast_intf_magic_number in
  let sg = Typemod.transl_signature (initial_env()) ast in
  Warnings.check_fatal ();
  (ast, sg, inputfile)
*)

(*#########################################################################*)
charguer's avatar
charguer committed
159
(* added -- TODO: avoid copy-paste! *)
charguer's avatar
init  
charguer committed
160 161 162 163

let typecheck_implementation_file ppf sourcefile parsetree =
  init_path ();
  let prefixname = Filename.chop_extension sourcefile in
charguer's avatar
charguer committed
164
  let modulename = String.capitalize_ascii (Filename.basename prefixname) in
charguer's avatar
init  
charguer committed
165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182
  Env.set_unit_name modulename;
  (* let inputfile = preprocess sourcefile in*)
  let env = initial_env () in
  try
    (* let parsetree = parse_file inputfile Parse.implementation ast_impl_magic_number in *)
    let typedtree = Typemod.type_implementation sourcefile prefixname modulename env parsetree in
    Some typedtree
  with
    e -> (* todo: factorize with above *)
      match e with
        Syntaxerr.Error err ->
          fprintf Format.err_formatter "@[%a@]@."
            Syntaxerr.report_error err;
          None
      | Failure s ->
          prerr_endline s;
          (*incr Odoc_global.errors ;*)
          None
charguer's avatar
charguer committed
183
      | Env.Error err ->
charguer's avatar
init  
charguer committed
184 185 186
          Env.report_error ppf err;
          print_newline();
          raise e
charguer's avatar
charguer committed
187
      | Typetexp.Error (loc,err) ->
charguer's avatar
init  
charguer committed
188 189 190 191
          Location.print_error ppf loc;
          Typetexp.report_error ppf err;
          print_newline();
          raise e
charguer's avatar
charguer committed
192
      | Typecore.Error (loc,err) ->
charguer's avatar
init  
charguer committed
193
          Location.print_error ppf loc;
charguer's avatar
charguer committed
194
          Typecore.report_error ppf err;
charguer's avatar
init  
charguer committed
195 196
          print_newline();
          raise e
charguer's avatar
charguer committed
197
      | Typemod.Error (loc,err) ->
charguer's avatar
init  
charguer committed
198 199 200 201 202 203 204 205 206 207 208
          Location.print_error ppf loc;
          Typemod.report_error ppf err;
          print_newline();
          raise e
      | e ->
          raise e


let typecheck_interface_file ppf sourcefile output_prefix =
  init_path ();
  let prefixname = Filename.chop_extension sourcefile in
charguer's avatar
charguer committed
209
  let modulename = String.capitalize_ascii (Filename.basename prefixname) in
charguer's avatar
init  
charguer committed
210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227
  Env.set_unit_name modulename;
  let inputfile = preprocess sourcefile in
  let ast = parse_file inputfile Parse.interface ast_intf_magic_number in
  let sg_opt = try
    let sg = Typemod.transl_signature (initial_env()) ast in
    Warnings.check_fatal ();
    Some sg
  with
    e -> (* todo: factorize with above *)
      match e with
        Syntaxerr.Error err ->
          fprintf Format.err_formatter "@[%a@]@."
            Syntaxerr.report_error err;
          None
      | Failure s ->
          prerr_endline s;
          (*incr Odoc_global.errors ;*)
          None
charguer's avatar
charguer committed
228
      | Env.Error err ->
charguer's avatar
init  
charguer committed
229 230 231
          Env.report_error ppf err;
          print_newline();
          raise e
charguer's avatar
charguer committed
232
      | Typetexp.Error (loc,err) ->
charguer's avatar
init  
charguer committed
233 234 235 236
          Location.print_error ppf loc;
          Typetexp.report_error ppf err;
          print_newline();
          raise e
charguer's avatar
charguer committed
237
      | Typecore.Error (loc,err) ->
charguer's avatar
init  
charguer committed
238
          Location.print_error ppf loc;
charguer's avatar
charguer committed
239
          Typecore.report_error ppf err;
charguer's avatar
init  
charguer committed
240 241
          print_newline();
          raise e
charguer's avatar
charguer committed
242
      | Typemod.Error (loc,err) ->
charguer's avatar
init  
charguer committed
243 244 245 246 247 248 249 250 251 252 253
          Location.print_error ppf loc;
          Typemod.report_error ppf err;
          print_newline();
          raise e
      | e ->
          raise e
     in
  match sg_opt with
  | None -> failwith "could not typecheck"
  | Some sg -> Env.save_signature sg.sig_type modulename (output_prefix ^ ".cmj")