API tools faq
paste
Guest User

Untitled

a guest
Feb 16th, 2019
95
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 8.83 KB | None | 0 0
raw download clone embed print report
  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)
Add Comment
Please, Sign In to add comment
Public Pastes
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
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!