daily pastebin goal
52%
SHARE
TWEET

Untitled

a guest Feb 16th, 2019 62 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. From 3793d48c1696cf3edd211e3fe697f4f3b1983e17 Mon Sep 17 00:00:00 2001
  2. From: nickgian <nick.giannarakis@gmail.com>
  3. Date: Sun, 4 Aug 2013 22:26:50 +0300
  4. Subject: [PATCH] Print directives
  5.  
  6. ---
  7.  toplevel/topdirs.ml  | 116 ++++++++++++++++++++++++++++++++++++---------------
  8.  toplevel/toploop.ml  |   9 +++-
  9.  toplevel/toploop.mli |   6 +++
  10.  3 files changed, 97 insertions(+), 34 deletions(-)
  11.  
  12. diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml
  13. index a679f8c..c33693d 100644
  14. --- a/toplevel/topdirs.ml
  15. +++ b/toplevel/topdirs.ml
  16. @@ -27,7 +27,9 @@ let std_out = std_formatter
  17.  
  18.  let dir_quit () = exit 0
  19.  
  20. -let _ = Hashtbl.add directive_table "quit" (Directive_none dir_quit)
  21. +let _ = add_directive "quit" (Directive_none dir_quit)
  22. +          "Exit the toplevel."
  23. +
  24.  
  25.  (* To add a directory to the load path *)
  26.  
  27. @@ -36,7 +38,8 @@ let dir_directory s =
  28.    Config.load_path := d :: !Config.load_path;
  29.    Dll.add_path [d]
  30.  
  31. -let _ = Hashtbl.add directive_table "directory" (Directive_string dir_directory)
  32. +let _ = add_directive "directory" (Directive_string dir_directory)
  33. +           "Add the given directory to search path for source and compiled files."
  34.  
  35.  (* To remove a directory from the load path *)
  36.  let dir_remove_directory s =
  37. @@ -44,15 +47,16 @@ let dir_remove_directory s =
  38.    Config.load_path := List.filter (fun d' -> d' <> d) !Config.load_path;
  39.    Dll.remove_path [d]
  40.  
  41. -let _ =
  42. -  Hashtbl.add directive_table "remove_directory"
  43. -    (Directive_string dir_remove_directory)
  44. +let _ = add_directive "remove_directory" (Directive_string dir_remove_directory)
  45. +           "Remove the given directory from the search path."
  46.  
  47.  (* To change the current directory *)
  48.  
  49.  let dir_cd s = Sys.chdir s
  50.  
  51. -let _ = Hashtbl.add directive_table "cd" (Directive_string dir_cd)
  52. +let _ = add_directive "cd" (Directive_string dir_cd)
  53. +          "Change the current working directory."
  54. +
  55.  
  56.  (* Load in-core a .cmo file *)
  57.  
  58. @@ -153,11 +157,15 @@ and really_load_file recursive ppf name filename ic =
  59.  
  60.  let dir_load ppf name = ignore (load_file false ppf name)
  61.  
  62. -let _ = Hashtbl.add directive_table "load" (Directive_string (dir_load std_out))
  63. +let _ = add_directive "load" (Directive_string (dir_load std_out))
  64. +           "Load in memory a bytecode object, produced by ocamlc."
  65.  
  66.  let dir_load_rec ppf name = ignore (load_file true ppf name)
  67.  
  68. -let _ = Hashtbl.add directive_table "load_rec" (Directive_string (dir_load_rec std_out))
  69. +let _ = add_directive "load_rec" (Directive_string (dir_load_rec std_out))
  70. +           "Also load modules that the object file depends on."
  71. +
  72. +
  73.  
  74.  let load_file = load_file false
  75.  
  76. @@ -166,8 +174,11 @@ let load_file = load_file false
  77.  let dir_use ppf name = ignore(Toploop.use_file ppf name)
  78.  let dir_mod_use ppf name = ignore(Toploop.mod_use_file ppf name)
  79.  
  80. -let _ = Hashtbl.add directive_table "use" (Directive_string (dir_use std_out))
  81. -let _ = Hashtbl.add directive_table "mod_use" (Directive_string (dir_mod_use std_out))
  82. +let _ = add_directive "use" (Directive_string (dir_use std_out))
  83. +          "Read, compile and execute source phrases from the given file."
  84. +
  85. +let _ = add_directive "mod_use" (Directive_string (dir_mod_use std_out))
  86. +    "Usage is identical to #use but #mod_use wraps the contents in a module."
  87.  
  88.  (* Install, remove a printer *)
  89.  
  90. @@ -231,10 +242,15 @@ let dir_remove_printer ppf lid =
  91.      end
  92.    with Exit -> ()
  93.  
  94. -let _ = Hashtbl.add directive_table "install_printer"
  95. -             (Directive_ident (dir_install_printer std_out))
  96. -let _ = Hashtbl.add directive_table "remove_printer"
  97. -             (Directive_ident (dir_remove_printer std_out))
  98. +
  99. +let _ = add_directive "install_printer"
  100. +          (Directive_ident (dir_install_printer std_out))
  101. +          "Registers a printer for values of a certain type."
  102. +
  103. +let _ = add_directive "remove_printer"
  104. +          (Directive_ident (dir_remove_printer std_out))
  105. +          "Remove the named function from the table of toplevel printers."
  106. +
  107.  
  108.  (* The trace *)
  109.  
  110. @@ -309,32 +325,66 @@ let parse_warnings ppf iserr s =
  111.    try Warnings.parse_options iserr s
  112.    with Arg.Bad err -> fprintf ppf "%s.@." err
  113.  
  114. -let _ =
  115. -  Hashtbl.add directive_table "trace" (Directive_ident (dir_trace std_out));
  116. -  Hashtbl.add directive_table "untrace" (Directive_ident (dir_untrace std_out));
  117. -  Hashtbl.add directive_table
  118. -    "untrace_all" (Directive_none (dir_untrace_all std_out));
  119. +let _ = add_directive "trace"
  120. +          (Directive_ident (dir_trace std_out))
  121. +          "All calls to the function named \
  122. +           function-name will be traced."
  123. +
  124. +let _ = add_directive "untrace"
  125. +          (Directive_ident (dir_untrace std_out))
  126. +          "Stop tracing the given function."
  127. +
  128. +let _ = add_directive "untrace_all"
  129. +          (Directive_none (dir_untrace_all std_out))
  130. +          "Stop tracing all functions traced so far."
  131. +
  132.  
  133.  (* Control the printing of values *)
  134.  
  135. -  Hashtbl.add directive_table "print_depth"
  136. -             (Directive_int(fun n -> max_printer_depth := n));
  137. -  Hashtbl.add directive_table "print_length"
  138. -             (Directive_int(fun n -> max_printer_steps := n));
  139. +let _ = add_directive "print_depth"
  140. +          (Directive_int(fun n -> max_printer_depth := n))
  141. +          "Limit the printing of values to a maximal depth of n."
  142. +
  143. +let _ = add_directive "print_length"
  144. +          (Directive_int(fun n -> max_printer_steps := n))
  145. +          "Limit the number of value nodes printed to at most n."
  146.  
  147.  (* Set various compiler flags *)
  148.  
  149. -  Hashtbl.add directive_table "labels"
  150. -             (Directive_bool(fun b -> Clflags.classic := not b));
  151. +let _ = add_directive "labels"
  152. +          (Directive_bool(fun b -> Clflags.classic := not b))
  153. +        "Choose whether to ignore labels in function types."
  154. +
  155. +let _ = add_directive "principal"
  156. +         (Directive_bool(fun b -> Clflags.principal := b))
  157. +        "Make sure that all types are derived in a principal way."
  158. +
  159. +let _ = add_directive "rectypes"
  160. +          (Directive_none(fun () -> Clflags.recursive_types := true))
  161. +        "Allow arbitrary recursive types during type-checking."
  162. +
  163. +let _ = add_directive "warnings"
  164. +          (Directive_string (parse_warnings std_out false))
  165. +        "Enable or disable warnings according to the argument."
  166. +
  167. +let _ = add_directive "warn_error"
  168. +          (Directive_string (parse_warnings std_out true))
  169. +          "Treat as errors the warnings enabled by the argument."
  170. +
  171. +let pp_directive name descr =
  172. +  Printf.printf "#%-20s\t %-s\n" name descr
  173.  
  174. -  Hashtbl.add directive_table "principal"
  175. -             (Directive_bool(fun b -> Clflags.principal := b));
  176.  
  177. -  Hashtbl.add directive_table "rectypes"
  178. -             (Directive_none(fun () -> Clflags.recursive_types := true));
  179. +let print_directives () =
  180. +  Printf.printf "Available directives: \n";
  181. +  Hashtbl.iter pp_directive directive_descr_table;
  182. +  if ((Hashtbl.length directive_table) != (Hashtbl.length directive_descr_table))
  183. +  then
  184. +    Hashtbl.iter (fun k _ -> if (Hashtbl.mem directive_descr_table k)
  185. +                                then ()
  186. +                                else pp_directive k "") directive_table
  187.  
  188. -  Hashtbl.add directive_table "warnings"
  189. -             (Directive_string (parse_warnings std_out false));
  190. +let _ = add_directive "help"
  191. +          (Directive_none (print_directives))
  192. +          "Prints a list of all available directives"
  193.  
  194. -  Hashtbl.add directive_table "warn_error"
  195. -             (Directive_string (parse_warnings std_out true))
  196. diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml
  197. index 636fe15..3e6244f 100644
  198. --- a/toplevel/toploop.ml
  199. +++ b/toplevel/toploop.ml
  200. @@ -225,7 +225,14 @@ let print_exception_outcome ppf exn =
  201.  (* The table of toplevel directives.
  202.     Filled by functions from module topdirs. *)
  203.  
  204. -let directive_table = (Hashtbl.create 13 : (string, directive_fun) Hashtbl.t)
  205. +let directive_table = (Hashtbl.create 23 : (string, directive_fun) Hashtbl.t)
  206. +
  207. +let directive_descr_table =
  208. +  (Hashtbl.create 23 : (string, string) Hashtbl.t)
  209. +
  210. +let add_directive name dir_fun descr =
  211. +  Hashtbl.add directive_table name dir_fun;
  212. +  Hashtbl.add directive_descr_table name descr
  213.  
  214.  (* Execute a toplevel phrase *)
  215.  
  216. diff --git a/toplevel/toploop.mli b/toplevel/toploop.mli
  217. index da607de..bf35963 100644
  218. --- a/toplevel/toploop.mli
  219. +++ b/toplevel/toploop.mli
  220. @@ -42,6 +42,11 @@ type directive_fun =
  221.  
  222.  val directive_table : (string, directive_fun) Hashtbl.t
  223.          (* Table of known directives, with their execution function *)
  224. +val directive_descr_table : (string, string) Hashtbl.t
  225. +        (* Table of known directives, with their description *)
  226. +val add_directive : string -> directive_fun -> string -> unit
  227. +        (* Add a directive to the directive tables.
  228. +           Usage : [add_directive name function descr] *)
  229.  val toplevel_env : Env.t ref
  230.          (* Typing environment for the toplevel *)
  231.  val initialize_toplevel_env : unit -> unit
  232. @@ -110,3 +115,4 @@ val toplevel_startup_hook : (unit -> unit) ref
  233.  (* Used by Trace module *)
  234.  
  235.  val may_trace : bool ref
  236. +
  237. --
  238. 1.7.12.4 (Apple Git-37)
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
 
Top