l4/pkg/ocaml/ocaml/contrib/toplevel/opttopdirs.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the Q Public License version 1.0.               *)
  10 (*                                                                     *)
  11 (***********************************************************************)
  12
  13 (* $Id: opttopdirs.ml 9134 2008-11-19 02:35:40Z garrigue $ *)
  14
  15 (* Toplevel directives *)
  16
  17 open Format
  18 open Misc
  19 open Longident
  20 open Path
  21 open Types
  22 open Opttoploop
  23
  24 (* The standard output formatter *)
  25 let std_out = std_formatter
  26
  27 (* To quit *)
  28
  29 let dir_quit () = exit 0
  30
  31 let _ = Hashtbl.add directive_table "quit" (Directive_none dir_quit)
  32
  33 (* To add a directory to the load path *)
  34
  35 let dir_directory s =
  36   let d = expand_directory Config.standard_library s in
  37   Config.load_path := d :: !Config.load_path
  38
  39 let _ = Hashtbl.add directive_table "directory" (Directive_string dir_directory)
  40 let _ = Hashtbl.add directive_table "show_dirs"
  41   (Directive_none
  42      (fun () ->
  43         List.iter print_endline !Config.load_path
  44      ))
  45
  46 (* To change the current directory *)
  47
  48 let dir_cd s = Sys.chdir s
  49
  50 let _ = Hashtbl.add directive_table "cd" (Directive_string dir_cd)
  51
  52 (* Load in-core a .cmxs file *)
  53
  54 let load_file ppf name0 =
  55   let name =
  56     try Some (find_in_path !Config.load_path name0)
  57     with Not_found -> None in
  58   match name with
  59     | None -> fprintf ppf "File not found: %s@." name0; false
  60     | Some name ->
  61   let fn,tmp =
  62     if Filename.check_suffix name ".cmx" || Filename.check_suffix name ".cmxa"
  63     then
  64       let cmxs = Filename.temp_file "caml" ".cmxs" in
  65       Asmlink.link_shared ppf [name] cmxs;
  66       cmxs,true
  67     else
  68       name,false in
  69
  70   let success =
  71     (* The Dynlink interface does not allow us to distinguish between
  72        a Dynlink.Error exceptions raised in the loaded modules
  73        or a genuine error during dynlink... *)
  74     try Dynlink.loadfile fn; true
  75     with
  76       | Dynlink.Error err ->
  77           fprintf ppf "Error while loading %s: %s.@."
  78             name (Dynlink.error_message err);
  79           false
  80       | exn ->
  81           print_exception_outcome ppf exn;
  82           false
  83   in
  84   if tmp then (try Sys.remove fn with Sys_error _ -> ());
  85   success
  86
  87
  88 let dir_load ppf name = ignore (load_file ppf name)
  89
  90 let _ = Hashtbl.add directive_table "load" (Directive_string (dir_load std_out))
  91
  92 (* Load commands from a file *)
  93
  94 let dir_use ppf name = ignore(Opttoploop.use_file ppf name)
  95
  96 let _ = Hashtbl.add directive_table "use" (Directive_string (dir_use std_out))
  97
  98 (* Install, remove a printer *)
  99
 100 type 'a printer_type_new = Format.formatter -> 'a -> unit
 101 type 'a printer_type_old = 'a -> unit
 102
 103 let match_printer_type ppf desc typename =
 104   let (printer_type, _) =
 105     try
 106       Env.lookup_type (Ldot(Lident "Topdirs", typename)) !toplevel_env
 107     with Not_found ->
 108       fprintf ppf "Cannot find type Topdirs.%s.@." typename;
 109       raise Exit in
 110   Ctype.init_def(Ident.current_time());
 111   Ctype.begin_def();
 112   let ty_arg = Ctype.newvar() in
 113   Ctype.unify !toplevel_env
 114     (Ctype.newconstr printer_type [ty_arg])
 115     (Ctype.instance desc.val_type);
 116   Ctype.end_def();
 117   Ctype.generalize ty_arg;
 118   ty_arg
 119
 120 let find_printer_type ppf lid =
 121   try
 122     let (path, desc) = Env.lookup_value lid !toplevel_env in
 123     let (ty_arg, is_old_style) =
 124       try
 125         (match_printer_type ppf desc "printer_type_new", false)
 126       with Ctype.Unify _ ->
 127         (match_printer_type ppf desc "printer_type_old", true) in
 128     (ty_arg, path, is_old_style)
 129   with
 130   | Not_found ->
 131       fprintf ppf "Unbound value %a.@." Printtyp.longident lid;
 132       raise Exit
 133   | Ctype.Unify _ ->
 134       fprintf ppf "%a has a wrong type for a printing function.@."
 135       Printtyp.longident lid;
 136       raise Exit
 137
 138 let dir_install_printer ppf lid =
 139   try
 140     let (ty_arg, path, is_old_style) = find_printer_type ppf lid in
 141     let v = eval_path path in
 142     let print_function =
 143       if is_old_style then
 144         (fun formatter repr -> Obj.obj v (Obj.obj repr))
 145       else
 146         (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in
 147     install_printer path ty_arg print_function
 148   with Exit -> ()
 149
 150 let dir_remove_printer ppf lid =
 151   try
 152     let (ty_arg, path, is_old_style) = find_printer_type ppf lid in
 153     begin try
 154       remove_printer path
 155     with Not_found ->
 156       fprintf ppf "No printer named %a.@." Printtyp.longident lid
 157     end
 158   with Exit -> ()
 159
 160 let _ = Hashtbl.add directive_table "install_printer"
 161              (Directive_ident (dir_install_printer std_out))
 162 let _ = Hashtbl.add directive_table "remove_printer"
 163              (Directive_ident (dir_remove_printer std_out))
 164
 165 let parse_warnings ppf iserr s =
 166   try Warnings.parse_options iserr s
 167   with Arg.Bad err -> fprintf ppf "%s.@." err
 168
 169 let _ =
 170 (* Control the printing of values *)
 171
 172   Hashtbl.add directive_table "print_depth"
 173              (Directive_int(fun n -> max_printer_depth := n));
 174   Hashtbl.add directive_table "print_length"
 175              (Directive_int(fun n -> max_printer_steps := n));
 176
 177 (* Set various compiler flags *)
 178
 179   Hashtbl.add directive_table "labels"
 180              (Directive_bool(fun b -> Clflags.classic := not b));
 181
 182   Hashtbl.add directive_table "principal"
 183              (Directive_bool(fun b -> Clflags.principal := b));
 184
 185   Hashtbl.add directive_table "rectypes"
 186              (Directive_none(fun () -> Clflags.recursive_types := true));
 187
 188   Hashtbl.add directive_table "warnings"
 189              (Directive_string (parse_warnings std_out false));
 190
 191   Hashtbl.add directive_table "warn_error"
 192              (Directive_string (parse_warnings std_out true))