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 Config
20 open Misc
21 open Parsetree
22 open Types
23 open Typedtree
24 open Outcometree
25 open Ast_helper
26
27 type res = Ok of Obj.t | Err of string
28 type evaluation_outcome = Result of Obj.t | Exception of exn
29
30 let _dummy = (Ok (Obj.magic 0), Err "")
31
32 external ndl_run_toplevel: string -> string -> res
33 = "caml_natdynlink_run_toplevel"
34
35 let global_symbol id =
36 let sym = Compilenv.symbol_for_global id in
37 match Dynlink.unsafe_get_global_value ~bytecode_or_asm_symbol:sym with
38 | None ->
39 fatal_error ("Opttoploop.global_symbol " ^ (Ident.unique_name id))
40 | Some obj -> obj
41
42 let need_symbol sym =
43 Option.is_none (Dynlink.unsafe_get_global_value ~bytecode_or_asm_symbol:sym)
44
45 let dll_run dll entry =
46 match (try Result (Obj.magic (ndl_run_toplevel dll entry))
47 with exn -> Exception exn)
48 with
49 | Exception _ as r -> r
50 | Result r ->
51 match Obj.magic r with
52 | Ok x -> Result x
53 | Err s -> fatal_error ("Opttoploop.dll_run " ^ s)
54
55
56 type directive_fun =
57 | Directive_none of (unit -> unit)
58 | Directive_string of (string -> unit)
59 | Directive_int of (int -> unit)
60 | Directive_ident of (Longident.t -> unit)
61 | Directive_bool of (bool -> unit)
62
63
64 let remembered = ref Ident.empty
65
66 let rec remember phrase_name i = function
67 | [] -> ()
68 | Sig_value (id, _, _) :: rest
69 | Sig_module (id, _, _, _, _) :: rest
70 | Sig_typext (id, _, _, _) :: rest
71 | Sig_class (id, _, _, _) :: rest ->
72 remembered := Ident.add id (phrase_name, i) !remembered;
73 remember phrase_name (succ i) rest
74 | _ :: rest -> remember phrase_name i rest
75
76 let toplevel_value id =
77 try Ident.find_same id !remembered
78 with _ -> Misc.fatal_error @@ "Unknown ident: " ^ Ident.unique_name id
79
80 let close_phrase lam =
81 let open Lambda in
82 Ident.Set.fold (fun id l ->
83 let glb, pos = toplevel_value id in
84 let glob =
85 Lprim (Pfield pos,
86 [Lprim (Pgetglobal glb, [], Location.none)],
87 Location.none)
88 in
89 Llet(Strict, Pgenval, id, glob, l)
90 ) (free_variables lam) lam
91
92 let toplevel_value id =
93 let glob, pos =
94 if Config.flambda then toplevel_value id else Translmod.nat_toplevel_name id
95 in
96 (Obj.magic (global_symbol glob)).(pos)
97
98 (* Return the value referred to by a path *)
99
100 let rec eval_address = function
101 | Env.Aident id ->
102 if Ident.persistent id || Ident.global id
103 then global_symbol id
104 else toplevel_value id
105 | Env.Adot(a, pos) ->
106 Obj.field (eval_address a) pos
107
108 let eval_path find env path =
109 match find path env with
110 | addr -> eval_address addr
111 | exception Not_found ->
112 fatal_error ("Cannot find address for: " ^ (Path.name path))
113
114 let eval_module_path env path =
115 eval_path Env.find_module_address env path
116
117 let eval_value_path env path =
118 eval_path Env.find_value_address env path
119
120 let eval_extension_path env path =
121 eval_path Env.find_constructor_address env path
122
123 let eval_class_path env path =
124 eval_path Env.find_class_address env path
125
126 (* To print values *)
127
128 module EvalPath = struct
129 type valu = Obj.t
130 exception Error
131 let eval_address addr =
132 try eval_address addr with _ -> raise Error
133 let same_value v1 v2 = (v1 == v2)
134 end
135
136 module Printer = Genprintval.Make(Obj)(EvalPath)
137
138 let max_printer_depth = ref 100
139 let max_printer_steps = ref 300
140
141 let print_out_value = Oprint.out_value
142 let print_out_type = Oprint.out_type
143 let print_out_class_type = Oprint.out_class_type
144 let print_out_module_type = Oprint.out_module_type
145 let print_out_type_extension = Oprint.out_type_extension
146 let print_out_sig_item = Oprint.out_sig_item
147 let print_out_signature = Oprint.out_signature
148 let print_out_phrase = Oprint.out_phrase
149
150 let print_untyped_exception ppf obj =
151 !print_out_value ppf (Printer.outval_of_untyped_exception obj)
152 let outval_of_value env obj ty =
153 Printer.outval_of_value !max_printer_steps !max_printer_depth
154 (fun _ _ _ -> None) env obj ty
155 let print_value env obj ppf ty =
156 !print_out_value ppf (outval_of_value env obj ty)
157
158 type ('a, 'b) gen_printer = ('a, 'b) Genprintval.gen_printer =
159 | Zero of 'b
160 | Succ of ('a -> ('a, 'b) gen_printer)
161
162 let install_printer = Printer.install_printer
163 let install_generic_printer = Printer.install_generic_printer
164 let install_generic_printer' = Printer.install_generic_printer'
165 let remove_printer = Printer.remove_printer
166
167 (* Hooks for parsing functions *)
168
169 let parse_toplevel_phrase = ref Parse.toplevel_phrase
170 let parse_use_file = ref Parse.use_file
171 let print_location = Location.print_loc
172 let print_error = Location.print_report
173 let print_warning = Location.print_warning
174 let input_name = Location.input_name
175
176 let parse_mod_use_file name lb =
177 let modname =
178 String.capitalize_ascii
179 (Filename.remove_extension (Filename.basename name))
180 in
181 let items =
182 List.concat
183 (List.map
184 (function Ptop_def s -> s | Ptop_dir _ -> [])
185 (!parse_use_file lb))
186 in
187 [ Ptop_def
188 [ Str.module_
189 (Mb.mk
190 (Location.mknoloc (Some modname))
191 (Mod.structure items)
192 )
193 ]
194 ]
195
196 (* Hook for initialization *)
197
198 let toplevel_startup_hook = ref (fun () -> ())
199
200 type event = ..
201 type event +=
202 | Startup
203 | After_setup
204
205 let hooks = ref []
206
207 let add_hook f = hooks := f :: !hooks
208
209 let () =
210 add_hook (function
211 | Startup -> !toplevel_startup_hook ()
212 | _ -> ())
213
214 let run_hooks hook = List.iter (fun f -> f hook) !hooks
215
216 (* Load in-core and execute a lambda term *)
217
218 let phrase_seqid = ref 0
219 let phrase_name = ref "TOP"
220
221 (* CR-soon trefis for mshinwell: copy/pasted from Optmain. Should it be shared
222 or?
223 mshinwell: It should be shared, but after 4.03. *)
224 module Backend = struct
225 (* See backend_intf.mli. *)
226
227 let symbol_for_global' = Compilenv.symbol_for_global'
228 let closure_symbol = Compilenv.closure_symbol
229
230 let really_import_approx = Import_approx.really_import_approx
231 let import_symbol = Import_approx.import_symbol
232
233 let size_int = Arch.size_int
234 let big_endian = Arch.big_endian
235
236 let max_sensible_number_of_arguments =
237 (* The "-1" is to allow for a potential closure environment parameter. *)
238 Proc.max_arguments_for_tailcalls - 1
239 end
240 let backend = (module Backend : Backend_intf.S)
241
242 let load_lambda ppf ~module_ident ~required_globals lam size =
243 if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam;
244 let slam = Simplif.simplify_lambda lam in
245 if !Clflags.dump_lambda then fprintf ppf "%a@." Printlambda.lambda slam;
246
247 let dll =
248 if !Clflags.keep_asm_file then !phrase_name ^ ext_dll
249 else Filename.temp_file ("caml" ^ !phrase_name) ext_dll
250 in
251 let filename = Filename.chop_extension dll in
252 let program =
253 { Lambda.
254 code = slam;
255 main_module_block_size = size;
256 module_ident;
257 required_globals;
258 }
259 in
260 let middle_end =
261 if Config.flambda then Flambda_middle_end.lambda_to_clambda
262 else Closure_middle_end.lambda_to_clambda
263 in
264 Asmgen.compile_implementation ~toplevel:need_symbol
265 ~backend ~filename ~prefixname:filename
266 ~middle_end ~ppf_dump:ppf program;
267 Asmlink.call_linker_shared [filename ^ ext_obj] dll;
268 Sys.remove (filename ^ ext_obj);
269
270 let dll =
271 if Filename.is_implicit dll
272 then Filename.concat (Sys.getcwd ()) dll
273 else dll in
274 let res = dll_run dll !phrase_name in
275 (try Sys.remove dll with Sys_error _ -> ());
276 (* note: under windows, cannot remove a loaded dll
277 (should remember the handles, close them in at_exit, and then remove
278 files) *)
279 res
280
281 (* Print the outcome of an evaluation *)
282
283 let pr_item =
284 Printtyp.print_items
285 (fun env -> function
286 | Sig_value(id, {val_kind = Val_reg; val_type}, _) ->
287 Some (outval_of_value env (toplevel_value id) val_type)
288 | _ -> None
289 )
290
291 (* The current typing environment for the toplevel *)
292
293 let toplevel_env = ref Env.empty
294
295 (* Print an exception produced by an evaluation *)
296
297 let print_out_exception ppf exn outv =
298 !print_out_phrase ppf (Ophr_exception (exn, outv))
299
300 let print_exception_outcome ppf exn =
301 if exn = Out_of_memory then Gc.full_major ();
302 let outv = outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn in
303 print_out_exception ppf exn outv
304
305 (* The table of toplevel directives.
306 Filled by functions from module topdirs. *)
307
308 let directive_table = (Hashtbl.create 13 : (string, directive_fun) Hashtbl.t)
309
310 (* Execute a toplevel phrase *)
311
312 let execute_phrase print_outcome ppf phr =
313 match phr with
314 | Ptop_def sstr ->
315 let oldenv = !toplevel_env in
316 incr phrase_seqid;
317 phrase_name := Printf.sprintf "TOP%i" !phrase_seqid;
318 Compilenv.reset ?packname:None !phrase_name;
319 Typecore.reset_delayed_checks ();
320 let sstr, rewritten =
321 match sstr with
322 | [ { pstr_desc = Pstr_eval (e, attrs) ; pstr_loc = loc } ]
323 | [ { pstr_desc = Pstr_value (Asttypes.Nonrecursive,
324 [{ pvb_expr = e
325 ; pvb_pat = { ppat_desc = Ppat_any ; _ }
326 ; pvb_attributes = attrs
327 ; _ }])
328 ; pstr_loc = loc }
329 ] ->
330 let pat = Ast_helper.Pat.var (Location.mknoloc "_$") in
331 let vb = Ast_helper.Vb.mk ~loc ~attrs pat e in
332 [ Ast_helper.Str.value ~loc Asttypes.Nonrecursive [vb] ], true
333 | _ -> sstr, false
334 in
335 let (str, sg, names, newenv) = Typemod.type_toplevel_phrase oldenv sstr in
336 if !Clflags.dump_typedtree then Printtyped.implementation ppf str;
337 let sg' = Typemod.Signature_names.simplify newenv names sg in
338 (* Why is this done? *)
339 ignore (Includemod.signatures oldenv sg sg');
340 Typecore.force_delayed_checks ();
341 let module_ident, res, required_globals, size =
342 if Config.flambda then
343 let { Lambda.module_ident; main_module_block_size = size;
344 required_globals; code = res } =
345 Translmod.transl_implementation_flambda !phrase_name
346 (str, Tcoerce_none)
347 in
348 remember module_ident 0 sg';
349 module_ident, close_phrase res, required_globals, size
350 else
351 let size, res = Translmod.transl_store_phrases !phrase_name str in
352 Ident.create_persistent !phrase_name, res, Ident.Set.empty, size
353 in
354 Warnings.check_fatal ();
355 begin try
356 toplevel_env := newenv;
357 let res = load_lambda ppf ~required_globals ~module_ident res size in
358 let out_phr =
359 match res with
360 | Result _ ->
361 if Config.flambda then
362 (* CR-someday trefis: *)
363 ()
364 else
365 Compilenv.record_global_approx_toplevel ();
366 if print_outcome then
367 Printtyp.wrap_printing_env ~error:false oldenv (fun () ->
368 match str.str_items with
369 | [] -> Ophr_signature []
370 | _ ->
371 if rewritten then
372 match sg' with
373 | [ Sig_value (id, vd, _) ] ->
374 let outv =
375 outval_of_value newenv (toplevel_value id)
376 vd.val_type
377 in
378 let ty = Printtyp.tree_of_type_scheme vd.val_type in
379 Ophr_eval (outv, ty)
380 | _ -> assert false
381 else
382 Ophr_signature (pr_item oldenv sg'))
383 else Ophr_signature []
384 | Exception exn ->
385 toplevel_env := oldenv;
386 if exn = Out_of_memory then Gc.full_major();
387 let outv =
388 outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn
389 in
390 Ophr_exception (exn, outv)
391 in
392 !print_out_phrase ppf out_phr;
393 begin match out_phr with
394 | Ophr_eval (_, _) | Ophr_signature _ -> true
395 | Ophr_exception _ -> false
396 end
397 with x ->
398 toplevel_env := oldenv; raise x
399 end
400 | Ptop_dir {pdir_name = {Location.txt = dir_name}; pdir_arg } ->
401 let d =
402 try Some (Hashtbl.find directive_table dir_name)
403 with Not_found -> None
404 in
405 begin match d with
406 | None ->
407 fprintf ppf "Unknown directive `%s'.@." dir_name;
408 false
409 | Some d ->
410 match d, pdir_arg with
411 | Directive_none f, None -> f (); true
412 | Directive_string f, Some {pdira_desc = Pdir_string s} -> f s; true
413 | Directive_int f, Some {pdira_desc = Pdir_int (n,None)} ->
414 begin match Int_literal_converter.int n with
415 | n -> f n; true
416 | exception _ ->
417 fprintf ppf "Integer literal exceeds the range of \
418 representable integers for directive `%s'.@."
419 dir_name;
420 false
421 end
422 | Directive_int _, Some {pdira_desc = Pdir_int (_, Some _)} ->
423 fprintf ppf "Wrong integer literal for directive `%s'.@."
424 dir_name;
425 false
426 | Directive_ident f, Some {pdira_desc = Pdir_ident lid} -> f lid; true
427 | Directive_bool f, Some {pdira_desc = Pdir_bool b} -> f b; true
428 | _ ->
429 fprintf ppf "Wrong type of argument for directive `%s'.@."
430 dir_name;
431 false
432 end
433
434 (* Read and execute commands from a file, or from stdin if [name] is "". *)
435
436 let use_print_results = ref true
437
438 let preprocess_phrase ppf phr =
439 let phr =
440 match phr with
441 | Ptop_def str ->
442 let str =
443 Pparse.apply_rewriters_str ~restore:true ~tool_name:"ocaml" str
444 in
445 Ptop_def str
446 | phr -> phr
447 in
448 if !Clflags.dump_parsetree then Printast.top_phrase ppf phr;
449 if !Clflags.dump_source then Pprintast.top_phrase ppf phr;
450 phr
451
452 let use_file ppf wrap_mod name =
453 try
454 let (filename, ic, must_close) =
455 if name = "" then
456 ("(stdin)", stdin, false)
457 else begin
458 let filename = Load_path.find name in
459 let ic = open_in_bin filename in
460 (filename, ic, true)
461 end
462 in
463 let lb = Lexing.from_channel ic in
464 Location.init lb filename;
465 (* Skip initial #! line if any *)
466 Lexer.skip_hash_bang lb;
467 let success =
468 protect_refs [ R (Location.input_name, filename) ] (fun () ->
469 try
470 List.iter
471 (fun ph ->
472 let ph = preprocess_phrase ppf ph in
473 if not (execute_phrase !use_print_results ppf ph) then raise Exit)
474 (if wrap_mod then
475 parse_mod_use_file name lb
476 else
477 !parse_use_file lb);
478 true
479 with
480 | Exit -> false
481 | Sys.Break -> fprintf ppf "Interrupted.@."; false
482 | x -> Location.report_exception ppf x; false) in
483 if must_close then close_in ic;
484 success
485 with Not_found -> fprintf ppf "Cannot find file %s.@." name; false
486
487 let mod_use_file ppf name = use_file ppf true name
488 let use_file ppf name = use_file ppf false name
489
490 let use_silently ppf name =
491 protect_refs [ R (use_print_results, false) ] (fun () -> use_file ppf name)
492
493 (* Reading function for interactive use *)
494
495 let first_line = ref true
496 let got_eof = ref false;;
497
498 let read_input_default prompt buffer len =
499 output_string stdout prompt; flush stdout;
500 let i = ref 0 in
501 try
502 while true do
503 if !i >= len then raise Exit;
504 let c = input_char stdin in
505 Bytes.set buffer !i c;
506 incr i;
507 if c = '\n' then raise Exit;
508 done;
509 (!i, false)
510 with
511 | End_of_file ->
512 (!i, true)
513 | Exit ->
514 (!i, false)
515
516 let read_interactive_input = ref read_input_default
517
518 let refill_lexbuf buffer len =
519 if !got_eof then (got_eof := false; 0) else begin
520 let prompt =
521 if !Clflags.noprompt then ""
522 else if !first_line then "# "
523 else if !Clflags.nopromptcont then ""
524 else if Lexer.in_comment () then "* "
525 else " "
526 in
527 first_line := false;
528 let (len, eof) = !read_interactive_input prompt buffer len in
529 if eof then begin
530 Location.echo_eof ();
531 if len > 0 then got_eof := true;
532 len
533 end else
534 len
535 end
536
537 (* Toplevel initialization. Performed here instead of at the
538 beginning of loop() so that user code linked in with ocamlmktop
539 can call directives from Topdirs. *)
540
541 let _ =
542 Sys.interactive := true;
543 Compmisc.init_path ();
544 Clflags.dlcode := true;
545 ()
546
547 let find_ocamlinit () =
548 let ocamlinit = ".ocamlinit" in
549 if Sys.file_exists ocamlinit then Some ocamlinit else
550 let getenv var = match Sys.getenv var with
551 | exception Not_found -> None | "" -> None | v -> Some v
552 in
553 let exists_in_dir dir file = match dir with
554 | None -> None
555 | Some dir ->
556 let file = Filename.concat dir file in
557 if Sys.file_exists file then Some file else None
558 in
559 let home_dir () = getenv "HOME" in
560 let config_dir () =
561 if Sys.win32 then None else
562 match getenv "XDG_CONFIG_HOME" with
563 | Some _ as v -> v
564 | None ->
565 match home_dir () with
566 | None -> None
567 | Some dir -> Some (Filename.concat dir ".config")
568 in
569 let init_ml = Filename.concat "ocaml" "init.ml" in
570 match exists_in_dir (config_dir ()) init_ml with
571 | Some _ as v -> v
572 | None -> exists_in_dir (home_dir ()) ocamlinit
573
574 let load_ocamlinit ppf =
575 if !Clflags.noinit then ()
576 else match !Clflags.init_file with
577 | Some f -> if Sys.file_exists f then ignore (use_silently ppf f)
578 else fprintf ppf "Init file not found: \"%s\".@." f
579 | None ->
580 match find_ocamlinit () with
581 | None -> ()
582 | Some file -> ignore (use_silently ppf file)
583 ;;
584
585 let set_paths () =
586 (* Add whatever -I options have been specified on the command line,
587 but keep the directories that user code linked in with ocamlmktop
588 may have added to load_path. *)
589 let expand = Misc.expand_directory Config.standard_library in
590 let current_load_path = Load_path.get_paths () in
591 let load_path = List.concat [
592 [ "" ];
593 List.map expand (List.rev !Compenv.first_include_dirs);
594 List.map expand (List.rev !Clflags.include_dirs);
595 List.map expand (List.rev !Compenv.last_include_dirs);
596 current_load_path;
597 [expand "+camlp4"];
598 ]
599 in
600 Load_path.init load_path
601
602 let initialize_toplevel_env () =
603 toplevel_env := Compmisc.initial_env()
604
605 (* The interactive loop *)
606
607 exception PPerror
608
609 let loop ppf =
610 Location.formatter_for_warnings := ppf;
611 if not !Clflags.noversion then
612 fprintf ppf " OCaml version %s - native toplevel@.@." Config.version;
613 initialize_toplevel_env ();
614 let lb = Lexing.from_function refill_lexbuf in
615 Location.init lb "//toplevel//";
616 Location.input_name := "//toplevel//";
617 Location.input_lexbuf := Some lb;
618 Sys.catch_break true;
619 run_hooks After_setup;
620 load_ocamlinit ppf;
621 while true do
622 let snap = Btype.snapshot () in
623 try
624 Lexing.flush_input lb;
625 Location.reset();
626 first_line := true;
627 let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in
628 let phr = preprocess_phrase ppf phr in
629 Env.reset_cache_toplevel ();
630 if !Clflags.dump_parsetree then Printast.top_phrase ppf phr;
631 if !Clflags.dump_source then Pprintast.top_phrase ppf phr;
632 ignore(execute_phrase true ppf phr)
633 with
634 | End_of_file -> exit 0
635 | Sys.Break -> fprintf ppf "Interrupted.@."; Btype.backtrack snap
636 | PPerror -> ()
637 | x -> Location.report_exception ppf x; Btype.backtrack snap
638 done
639
640 external caml_sys_modify_argv : string array -> unit =
641 "caml_sys_modify_argv"
642
643 let override_sys_argv new_argv =
644 caml_sys_modify_argv new_argv;
645 Arg.current := 0
646
647 (* Execute a script. If [name] is "", read the script from stdin. *)
648
649 let run_script ppf name args =
650 override_sys_argv args;
651 Compmisc.init_path ~dir:(Filename.dirname name) ();
652 (* Note: would use [Filename.abspath] here, if we had it. *)
653 toplevel_env := Compmisc.initial_env();
654 Sys.interactive := false;
655 run_hooks After_setup;
656 let explicit_name =
657 (* Prevent use_silently from searching in the path. *)
658 if Filename.is_implicit name
659 then Filename.concat Filename.current_dir_name name
660 else name
661 in
662 use_silently ppf explicit_name
663