1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
6 (* *)
7 (* Copyright 1996 Institut National de Recherche en Informatique et *)
8 (* en Automatique. *)
9 (* *)
10 (* All rights reserved. This file is distributed under the terms of *)
11 (* the GNU Lesser General Public License version 2.1, with the *)
12 (* special exception on linking described in the file LICENSE. *)
13 (* *)
14 (**************************************************************************)
15
16 (* The interactive toplevel loop *)
17
18 open Format
19 open Misc
20 open Parsetree
21 open Types
22 open Typedtree
23 open Outcometree
24 open Ast_helper
25 module String = Misc.Stdlib.String
26
27 type directive_fun =
28 | Directive_none of (unit -> unit)
29 | Directive_string of (string -> unit)
30 | Directive_int of (int -> unit)
31 | Directive_ident of (Longident.t -> unit)
32 | Directive_bool of (bool -> unit)
33
34 type directive_info = {
35 section: string;
36 doc: string;
37 }
38
39 (* Phase buffer that stores the last toplevel phrase (see
40 [Location.input_phrase_buffer]). *)
41 let phrase_buffer = Buffer.create 1024
42
43 (* The table of toplevel value bindings and its accessors *)
44
45 let toplevel_value_bindings : Obj.t String.Map.t ref = ref String.Map.empty
46
47 let getvalue name =
48 try
49 String.Map.find name !toplevel_value_bindings
50 with Not_found ->
51 fatal_error (name ^ " unbound at toplevel")
52
53 let setvalue name v =
54 toplevel_value_bindings := String.Map.add name v !toplevel_value_bindings
55
56 (* Return the value referred to by a path *)
57
58 let rec eval_address = function
59 | Env.Aident id ->
60 if Ident.persistent id || Ident.global id then
61 Symtable.get_global_value id
62 else begin
63 let name = Translmod.toplevel_name id in
64 try
65 String.Map.find name !toplevel_value_bindings
66 with Not_found ->
67 raise (Symtable.Error(Symtable.Undefined_global name))
68 end
69 | Env.Adot(p, pos) ->
70 Obj.field (eval_address p) pos
71
72 let eval_path find env path =
73 match find path env with
74 | addr -> eval_address addr
75 | exception Not_found ->
76 fatal_error ("Cannot find address for: " ^ (Path.name path))
77
78 let eval_module_path env path =
79 eval_path Env.find_module_address env path
80
81 let eval_value_path env path =
82 eval_path Env.find_value_address env path
83
84 let eval_extension_path env path =
85 eval_path Env.find_constructor_address env path
86
87 let eval_class_path env path =
88 eval_path Env.find_class_address env path
89
90 (* To print values *)
91
92 module EvalPath = struct
93 type valu = Obj.t
94 exception Error
95 let eval_address addr =
96 try eval_address addr with Symtable.Error _ -> raise Error
97 let same_value v1 v2 = (v1 == v2)
98 end
99
100 module Printer = Genprintval.Make(Obj)(EvalPath)
101
102 let max_printer_depth = ref 100
103 let max_printer_steps = ref 300
104
105 let print_out_value = Oprint.out_value
106 let print_out_type = Oprint.out_type
107 let print_out_class_type = Oprint.out_class_type
108 let print_out_module_type = Oprint.out_module_type
109 let print_out_type_extension = Oprint.out_type_extension
110 let print_out_sig_item = Oprint.out_sig_item
111 let print_out_signature = Oprint.out_signature
112 let print_out_phrase = Oprint.out_phrase
113
114 let print_untyped_exception ppf obj =
115 !print_out_value ppf (Printer.outval_of_untyped_exception obj)
116 let outval_of_value env obj ty =
117 Printer.outval_of_value !max_printer_steps !max_printer_depth
118 (fun _ _ _ -> None) env obj ty
119 let print_value env obj ppf ty =
120 !print_out_value ppf (outval_of_value env obj ty)
121
122 type ('a, 'b) gen_printer = ('a, 'b) Genprintval.gen_printer =
123 | Zero of 'b
124 | Succ of ('a -> ('a, 'b) gen_printer)
125
126 let install_printer = Printer.install_printer
127 let install_generic_printer = Printer.install_generic_printer
128 let install_generic_printer' = Printer.install_generic_printer'
129 let remove_printer = Printer.remove_printer
130
131 (* Hooks for parsing functions *)
132
133 let parse_toplevel_phrase = ref Parse.toplevel_phrase
134 let parse_use_file = ref Parse.use_file
135 let print_location = Location.print_loc
136 let print_error = Location.print_report
137 let print_warning = Location.print_warning
138 let input_name = Location.input_name
139
140 let parse_mod_use_file name lb =
141 let modname =
142 String.capitalize_ascii
143 (Filename.remove_extension (Filename.basename name))
144 in
145 let items =
146 List.concat
147 (List.map
148 (function Ptop_def s -> s | Ptop_dir _ -> [])
149 (!parse_use_file lb))
150 in
151 [ Ptop_def
152 [ Str.module_
153 (Mb.mk
154 (Location.mknoloc (Some modname))
155 (Mod.structure items)
156 )
157 ]
158 ]
159
160 (* Hook for initialization *)
161
162 let toplevel_startup_hook = ref (fun () -> ())
163
164 type event = ..
165 type event +=
166 | Startup
167 | After_setup
168
169 let hooks = ref []
170
171 let add_hook f = hooks := f :: !hooks
172
173 let () =
174 add_hook (function
175 | Startup -> !toplevel_startup_hook ()
176 | _ -> ())
177
178 let run_hooks hook = List.iter (fun f -> f hook) !hooks
179
180 (* Load in-core and execute a lambda term *)
181
182 let may_trace = ref false (* Global lock on tracing *)
183 type evaluation_outcome = Result of Obj.t | Exception of exn
184
185 let backtrace = ref None
186
187 let record_backtrace () =
188 if Printexc.backtrace_status ()
189 then backtrace := Some (Printexc.get_backtrace ())
190
191 let load_lambda ppf lam =
192 if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam;
193 let slam = Simplif.simplify_lambda lam in
194 if !Clflags.dump_lambda then fprintf ppf "%a@." Printlambda.lambda slam;
195 let (init_code, fun_code) = Bytegen.compile_phrase slam in
196 if !Clflags.dump_instr then
197 fprintf ppf "%a%a@."
198 Printinstr.instrlist init_code
199 Printinstr.instrlist fun_code;
200 let (code, reloc, events) =
201 Emitcode.to_memory init_code fun_code
202 in
203 let can_free = (fun_code = []) in
204 let initial_symtable = Symtable.current_state() in
205 Symtable.patch_object code reloc;
206 Symtable.check_global_initialized reloc;
207 Symtable.update_global_table();
208 let initial_bindings = !toplevel_value_bindings in
209 let bytecode, closure = Meta.reify_bytecode code [| events |] None in
210 try
211 may_trace := true;
212 let retval = closure () in
213 may_trace := false;
214 if can_free then Meta.release_bytecode bytecode;
215 Result retval
216 with x ->
217 may_trace := false;
218 if can_free then Meta.release_bytecode bytecode;
219 record_backtrace ();
220 toplevel_value_bindings := initial_bindings; (* PR#6211 *)
221 Symtable.restore_state initial_symtable;
222 Exception x
223
224 (* Print the outcome of an evaluation *)
225
226 let pr_item =
227 Printtyp.print_items
228 (fun env -> function
229 | Sig_value(id, {val_kind = Val_reg; val_type}, _) ->
230 Some (outval_of_value env (getvalue (Translmod.toplevel_name id))
231 val_type)
232 | _ -> None
233 )
234
235 (* The current typing environment for the toplevel *)
236
237 let toplevel_env = ref Env.empty
238
239 (* Print an exception produced by an evaluation *)
240
241 let print_out_exception ppf exn outv =
242 !print_out_phrase ppf (Ophr_exception (exn, outv))
243
244 let print_exception_outcome ppf exn =
245 if exn = Out_of_memory then Gc.full_major ();
246 let outv = outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn in
247 print_out_exception ppf exn outv;
248 if Printexc.backtrace_status ()
249 then
250 match !backtrace with
251 | None -> ()
252 | Some b ->
253 print_string b;
254 backtrace := None
255
256
257 (* Inserting new toplevel directives *)
258
259 let directive_table = (Hashtbl.create 23 : (string, directive_fun) Hashtbl.t)
260
261 let directive_info_table =
262 (Hashtbl.create 23 : (string, directive_info) Hashtbl.t)
263
264 let add_directive name dir_fun dir_info =
265 Hashtbl.add directive_table name dir_fun;
266 Hashtbl.add directive_info_table name dir_info
267
268 (* Execute a toplevel phrase *)
269
270 let execute_phrase print_outcome ppf phr =
271 match phr with
272 | Ptop_def sstr ->
273 let oldenv = !toplevel_env in
274 Typecore.reset_delayed_checks ();
275 let (str, sg, sn, newenv) = Typemod.type_toplevel_phrase oldenv sstr in
276 if !Clflags.dump_typedtree then Printtyped.implementation ppf str;
277 let sg' = Typemod.Signature_names.simplify newenv sn sg in
278 ignore (Includemod.signatures oldenv sg sg');
279 Typecore.force_delayed_checks ();
280 let lam = Translmod.transl_toplevel_definition str in
281 Warnings.check_fatal ();
282 begin try
283 toplevel_env := newenv;
284 let res = load_lambda ppf lam in
285 let out_phr =
286 match res with
287 | Result v ->
288 if print_outcome then
289 Printtyp.wrap_printing_env ~error:false oldenv (fun () ->
290 match str.str_items with
291 | [ { str_desc =
292 (Tstr_eval (exp, _)
293 |Tstr_value
294 (Asttypes.Nonrecursive,
295 [{vb_pat = {pat_desc=Tpat_any};
296 vb_expr = exp}
297 ]
298 )
299 )
300 }
301 ] ->
302 let outv = outval_of_value newenv v exp.exp_type in
303 let ty = Printtyp.tree_of_type_scheme exp.exp_type in
304 Ophr_eval (outv, ty)
305
306 | [] -> Ophr_signature []
307 | _ -> Ophr_signature (pr_item oldenv sg'))
308 else Ophr_signature []
309 | Exception exn ->
310 toplevel_env := oldenv;
311 if exn = Out_of_memory then Gc.full_major();
312 let outv =
313 outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn
314 in
315 Ophr_exception (exn, outv)
316 in
317 !print_out_phrase ppf out_phr;
318 if Printexc.backtrace_status ()
319 then begin
320 match !backtrace with
321 | None -> ()
322 | Some b ->
323 pp_print_string ppf b;
324 pp_print_flush ppf ();
325 backtrace := None;
326 end;
327 begin match out_phr with
328 | Ophr_eval (_, _) | Ophr_signature _ -> true
329 | Ophr_exception _ -> false
330 end
331 with x ->
332 toplevel_env := oldenv; raise x
333 end
334 | Ptop_dir {pdir_name = {Location.txt = dir_name}; pdir_arg } ->
335 let d =
336 try Some (Hashtbl.find directive_table dir_name)
337 with Not_found -> None
338 in
339 begin match d with
340 | None ->
341 fprintf ppf "Unknown directive `%s'." dir_name;
342 let directives =
343 Hashtbl.fold (fun dir _ acc -> dir::acc) directive_table [] in
344 Misc.did_you_mean ppf
345 (fun () -> Misc.spellcheck directives dir_name);
346 fprintf ppf "@.";
347 false
348 | Some d ->
349 match d, pdir_arg with
350 | Directive_none f, None -> f (); true
351 | Directive_string f, Some {pdira_desc = Pdir_string s} -> f s; true
352 | Directive_int f, Some {pdira_desc = Pdir_int (n,None) } ->
353 begin match Int_literal_converter.int n with
354 | n -> f n; true
355 | exception _ ->
356 fprintf ppf "Integer literal exceeds the range of \
357 representable integers for directive `%s'.@."
358 dir_name;
359 false
360 end
361 | Directive_int _, Some {pdira_desc = Pdir_int (_, Some _)} ->
362 fprintf ppf "Wrong integer literal for directive `%s'.@."
363 dir_name;
364 false
365 | Directive_ident f, Some {pdira_desc = Pdir_ident lid} -> f lid; true
366 | Directive_bool f, Some {pdira_desc = Pdir_bool b} -> f b; true
367 | _ ->
368 fprintf ppf "Wrong type of argument for directive `%s'.@."
369 dir_name;
370 false
371 end
372
373 let execute_phrase print_outcome ppf phr =
374 try execute_phrase print_outcome ppf phr
375 with exn ->
376 Warnings.reset_fatal ();
377 raise exn
378
379 (* Read and execute commands from a file, or from stdin if [name] is "". *)
380
381 let use_print_results = ref true
382
383 let preprocess_phrase ppf phr =
384 let phr =
385 match phr with
386 | Ptop_def str ->
387 let str =
388 Pparse.apply_rewriters_str ~restore:true ~tool_name:"ocaml" str
389 in
390 Ptop_def str
391 | phr -> phr
392 in
393 if !Clflags.dump_parsetree then Printast.top_phrase ppf phr;
394 if !Clflags.dump_source then Pprintast.top_phrase ppf phr;
395 phr
396
397 let use_file ppf wrap_mod name =
398 try
399 let (filename, ic, must_close) =
400 if name = "" then
401 ("(stdin)", stdin, false)
402 else begin
403 let filename = Load_path.find name in
404 let ic = open_in_bin filename in
405 (filename, ic, true)
406 end
407 in
408 let lb = Lexing.from_channel ic in
409 Warnings.reset_fatal ();
410 Location.init lb filename;
411 (* Skip initial #! line if any *)
412 Lexer.skip_hash_bang lb;
413 let success =
414 protect_refs [ R (Location.input_name, filename);
415 R (Location.input_lexbuf, Some lb); ]
416 (fun () ->
417 try
418 List.iter
419 (fun ph ->
420 let ph = preprocess_phrase ppf ph in
421 if not (execute_phrase !use_print_results ppf ph) then raise Exit)
422 (if wrap_mod then
423 parse_mod_use_file name lb
424 else
425 !parse_use_file lb);
426 true
427 with
428 | Exit -> false
429 | Sys.Break -> fprintf ppf "Interrupted.@."; false
430 | x -> Location.report_exception ppf x; false) in
431 if must_close then close_in ic;
432 success
433 with Not_found -> fprintf ppf "Cannot find file %s.@." name; false
434
435 let mod_use_file ppf name = use_file ppf true name
436 let use_file ppf name = use_file ppf false name
437
438 let use_silently ppf name =
439 protect_refs [ R (use_print_results, false) ] (fun () -> use_file ppf name)
440
441 (* Reading function for interactive use *)
442
443 let first_line = ref true
444 let got_eof = ref false;;
445
446 let read_input_default prompt buffer len =
447 output_string stdout prompt; flush stdout;
448 let i = ref 0 in
449 try
450 while true do
451 if !i >= len then raise Exit;
452 let c = input_char stdin in
453 Bytes.set buffer !i c;
454 (* Also populate the phrase buffer as new characters are added. *)
455 Buffer.add_char phrase_buffer c;
456 incr i;
457 if c = '\n' then raise Exit;
458 done;
459 (!i, false)
460 with
461 | End_of_file ->
462 (!i, true)
463 | Exit ->
464 (!i, false)
465
466 let read_interactive_input = ref read_input_default
467
468 let refill_lexbuf buffer len =
469 if !got_eof then (got_eof := false; 0) else begin
470 let prompt =
471 if !Clflags.noprompt then ""
472 else if !first_line then "# "
473 else if !Clflags.nopromptcont then ""
474 else if Lexer.in_comment () then "* "
475 else " "
476 in
477 first_line := false;
478 let (len, eof) = !read_interactive_input prompt buffer len in
479 if eof then begin
480 Location.echo_eof ();
481 if len > 0 then got_eof := true;
482 len
483 end else
484 len
485 end
486
487 (* Toplevel initialization. Performed here instead of at the
488 beginning of loop() so that user code linked in with ocamlmktop
489 can call directives from Topdirs. *)
490
491 let _ =
492 if !Sys.interactive then (* PR#6108 *)
493 invalid_arg "The ocamltoplevel.cma library from compiler-libs \
494 cannot be loaded inside the OCaml toplevel";
495 Sys.interactive := true;
496 let crc_intfs = Symtable.init_toplevel() in
497 Compmisc.init_path ();
498 Env.import_crcs ~source:Sys.executable_name crc_intfs;
499 ()
500
501 let find_ocamlinit () =
502 let ocamlinit = ".ocamlinit" in
503 if Sys.file_exists ocamlinit then Some ocamlinit else
504 let getenv var = match Sys.getenv var with
505 | exception Not_found -> None | "" -> None | v -> Some v
506 in
507 let exists_in_dir dir file = match dir with
508 | None -> None
509 | Some dir ->
510 let file = Filename.concat dir file in
511 if Sys.file_exists file then Some file else None
512 in
513 let home_dir () = getenv "HOME" in
514 let config_dir () =
515 if Sys.win32 then None else
516 match getenv "XDG_CONFIG_HOME" with
517 | Some _ as v -> v
518 | None ->
519 match home_dir () with
520 | None -> None
521 | Some dir -> Some (Filename.concat dir ".config")
522 in
523 let init_ml = Filename.concat "ocaml" "init.ml" in
524 match exists_in_dir (config_dir ()) init_ml with
525 | Some _ as v -> v
526 | None -> exists_in_dir (home_dir ()) ocamlinit
527
528 let load_ocamlinit ppf =
529 if !Clflags.noinit then ()
530 else match !Clflags.init_file with
531 | Some f -> if Sys.file_exists f then ignore (use_silently ppf f)
532 else fprintf ppf "Init file not found: \"%s\".@." f
533 | None ->
534 match find_ocamlinit () with
535 | None -> ()
536 | Some file -> ignore (use_silently ppf file)
537 ;;
538
539 let set_paths () =
540 (* Add whatever -I options have been specified on the command line,
541 but keep the directories that user code linked in with ocamlmktop
542 may have added to load_path. *)
543 let expand = Misc.expand_directory Config.standard_library in
544 let current_load_path = Load_path.get_paths () in
545 let load_path = List.concat [
546 [ "" ];
547 List.map expand (List.rev !Compenv.first_include_dirs);
548 List.map expand (List.rev !Clflags.include_dirs);
549 List.map expand (List.rev !Compenv.last_include_dirs);
550 current_load_path;
551 [expand "+camlp4"];
552 ]
553 in
554 Load_path.init load_path;
555 Dll.add_path load_path
556
557 let initialize_toplevel_env () =
558 toplevel_env := Compmisc.initial_env()
559
560 (* The interactive loop *)
561
562 exception PPerror
563
564 let loop ppf =
565 Clflags.debug := true;
566 Location.formatter_for_warnings := ppf;
567 if not !Clflags.noversion then
568 fprintf ppf " OCaml version %s@.@." Config.version;
569 begin
570 try initialize_toplevel_env ()
571 with Env.Error _ | Typetexp.Error _ as exn ->
572 Location.report_exception ppf exn; exit 2
573 end;
574 let lb = Lexing.from_function refill_lexbuf in
575 Location.init lb "//toplevel//";
576 Location.input_name := "//toplevel//";
577 Location.input_lexbuf := Some lb;
578 Location.input_phrase_buffer := Some phrase_buffer;
579 Sys.catch_break true;
580 run_hooks After_setup;
581 load_ocamlinit ppf;
582 while true do
583 let snap = Btype.snapshot () in
584 try
585 Lexing.flush_input lb;
586 (* Reset the phrase buffer when we flush the lexing buffer. *)
587 Buffer.reset phrase_buffer;
588 Location.reset();
589 Warnings.reset_fatal ();
590 first_line := true;
591 let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in
592 let phr = preprocess_phrase ppf phr in
593 Env.reset_cache_toplevel ();
594 ignore(execute_phrase true ppf phr)
595 with
596 | End_of_file -> exit 0
597 | Sys.Break -> fprintf ppf "Interrupted.@."; Btype.backtrack snap
598 | PPerror -> ()
599 | x -> Location.report_exception ppf x; Btype.backtrack snap
600 done
601
602 external caml_sys_modify_argv : string array -> unit =
603 "caml_sys_modify_argv"
604
605 let override_sys_argv new_argv =
606 caml_sys_modify_argv new_argv;
607 Arg.current := 0
608
609 (* Execute a script. If [name] is "", read the script from stdin. *)
610
611 let run_script ppf name args =
612 override_sys_argv args;
613 Compmisc.init_path ~dir:(Filename.dirname name) ();
614 (* Note: would use [Filename.abspath] here, if we had it. *)
615 begin
616 try toplevel_env := Compmisc.initial_env()
617 with Env.Error _ | Typetexp.Error _ as exn ->
618 Location.report_exception ppf exn; exit 2
619 end;
620 Sys.interactive := false;
621 run_hooks After_setup;
622 let explicit_name =
623 (* Prevent use_silently from searching in the path. *)
624 if name <> "" && Filename.is_implicit name
625 then Filename.concat Filename.current_dir_name name
626 else name
627 in
628 use_silently ppf explicit_name
629