Un imprimeur des valeurs manipulées par le compilateur (histoire de
comprendre quelquechose en debuguant). git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@2831 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02master
Pierre Weis
parent
fbde7dd45d
commit
cfc2ad8276
|
|
@ -0,0 +1,170 @@
|
|||
(*************************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml LablTk library *)
|
||||
(* *)
|
||||
(* Pierre Weis, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 2000 Institut National de Recherche en Informatique et *)
|
||||
(* en Automatique and Kyoto University. All rights reserved. *)
|
||||
(* This file is distributed under the terms of the GNU Library *)
|
||||
(* General Public License. *)
|
||||
(* *)
|
||||
(*************************************************************************)
|
||||
|
||||
open Tables;;
|
||||
|
||||
open Format;;
|
||||
|
||||
let escape_string s =
|
||||
let more = ref 0 in
|
||||
for i = 0 to String.length s - 1 do
|
||||
match s.[i] with
|
||||
| '\\' | '"' -> incr more
|
||||
| _ -> ()
|
||||
done;
|
||||
if !more = 0 then s else
|
||||
let res = String.create len:(String.length s + !more) in
|
||||
let j = ref 0 in
|
||||
for i = 0 to String.length s - 1 do
|
||||
let c = s.[i] in
|
||||
match c with
|
||||
| '\\' | '"' -> res.[!j] <- '\\'; incr j; res.[!j] <- c; incr j
|
||||
| _ -> res.[!j] <- c; incr j
|
||||
done;
|
||||
res;;
|
||||
|
||||
let escape_char c = if c = '\'' then "\\'" else String.make len:1 c;;
|
||||
|
||||
let print_quoted_string s = printf "\"%s\"" (escape_string s);;
|
||||
let print_quoted_char c = printf "'%s'" (escape_char c);;
|
||||
let print_quoted_int i =
|
||||
if i < 0 then printf "(%d)" i else printf "%d" i;;
|
||||
let print_quoted_float f =
|
||||
if f <= 0.0 then printf "(%f)" f else printf "%f" f;;
|
||||
|
||||
(* Iterators *)
|
||||
let print_list f l =
|
||||
printf "@[<1>[";
|
||||
let rec pl = function
|
||||
| [] -> printf "@;<0 -1>]@]"
|
||||
| [x] -> f x; pl []
|
||||
| x :: xs -> f x; printf ";@ "; pl xs in
|
||||
pl l;;
|
||||
|
||||
let print_array f v =
|
||||
printf "@[<2>[|";
|
||||
let l = Array.length v in
|
||||
if l >= 1 then f v.(0);
|
||||
if l >= 2 then
|
||||
for i = 1 to l - 1 do
|
||||
printf ";@ "; f v.(i)
|
||||
done;
|
||||
printf "@;<0 -1>|]@]";;
|
||||
|
||||
let print_option f = function
|
||||
| None -> print_string "None"
|
||||
| Some x -> printf "@[<1>Some@ "; f x; printf "@]";;
|
||||
|
||||
let print_bool = function
|
||||
| true -> print_string "true" | _ -> print_string "false";;
|
||||
|
||||
let print_poly x = print_string "<poly>";;
|
||||
|
||||
(* Types of the description language *)
|
||||
let rec print_mltype = function
|
||||
| Unit -> printf "Unit" | Int -> printf "Int" | Float -> printf "Float"
|
||||
| Bool -> printf "Bool" | Char -> printf "Char" | String -> printf "String"
|
||||
| List m -> printf "@[<1>(%s@ " "List"; print_mltype m; printf ")@]"
|
||||
| Product l_m ->
|
||||
printf "@[<1>(%s@ " "Product"; print_list print_mltype l_m; printf ")@]"
|
||||
| Record l_t_s_m ->
|
||||
printf "@[<1>(%s@ " "Record";
|
||||
print_list
|
||||
(function (s, m) ->
|
||||
printf "@[<1>("; print_quoted_string s; printf ",@ "; print_mltype m;
|
||||
printf ")@]")
|
||||
l_t_s_m;
|
||||
printf ")@]"
|
||||
| UserDefined s ->
|
||||
printf "@[<1>(%s@ " "UserDefined"; print_quoted_string s; printf ")@]"
|
||||
| Subtype (s, s0) ->
|
||||
printf "@[<1>(%s@ " "Subtype"; printf "@[<1>("; print_quoted_string s;
|
||||
printf ",@ "; print_quoted_string s0; printf ")@]"; printf ")@]"
|
||||
| Function m ->
|
||||
printf "@[<1>(%s@ " "Function"; print_mltype m; printf ")@]"
|
||||
| As (m, s) ->
|
||||
printf "@[<1>(%s@ " "As"; printf "@[<1>("; print_mltype m; printf ",@ ";
|
||||
print_quoted_string s; printf ")@]"; printf ")@]";;
|
||||
|
||||
let rec print_template = function
|
||||
| StringArg s ->
|
||||
printf "@[<1>(%s@ " "StringArg"; print_quoted_string s; printf ")@]"
|
||||
| TypeArg (s, m) ->
|
||||
printf "@[<1>(%s@ " "TypeArg"; printf "@[<1>("; print_quoted_string s;
|
||||
printf ",@ "; print_mltype m; printf ")@]"; printf ")@]"
|
||||
| ListArg l_t ->
|
||||
printf "@[<1>(%s@ " "ListArg"; print_list print_template l_t;
|
||||
printf ")@]"
|
||||
| OptionalArgs (s, l_t, l_t0) ->
|
||||
printf "@[<1>(%s@ " "OptionalArgs"; printf "@[<1>(";
|
||||
print_quoted_string s; printf ",@ "; print_list print_template l_t;
|
||||
printf ",@ "; print_list print_template l_t0; printf ")@]"; printf ")@]";;
|
||||
|
||||
(* Sorts of components *)
|
||||
let rec print_component_type = function
|
||||
| Constructor -> printf "Constructor" | Command -> printf "Command"
|
||||
| External -> printf "External";;
|
||||
|
||||
(* Full definition of a component *)
|
||||
let rec print_fullcomponent = function
|
||||
{component = c; ml_name = s; var_name = s0; template = t; result = m;
|
||||
safe = b;
|
||||
} ->
|
||||
printf "@[<1>{"; printf "@[<1>component =@ "; print_component_type c;
|
||||
printf ";@]@ "; printf "@[<1>ml_name =@ "; print_quoted_string s;
|
||||
printf ";@]@ "; printf "@[<1>var_name =@ "; print_quoted_string s0;
|
||||
printf ";@]@ "; printf "@[<1>template =@ "; print_template t;
|
||||
printf ";@]@ "; printf "@[<1>result =@ "; print_mltype m; printf ";@]@ ";
|
||||
printf "@[<1>safe =@ "; print_bool b; printf ";@]@ "; printf "@,}@]";;
|
||||
|
||||
(* components are given either in full or abbreviated *)
|
||||
let rec print_component = function
|
||||
| Full f -> printf "@[<1>(%s@ " "Full"; print_fullcomponent f; printf ")@]"
|
||||
| Abbrev s ->
|
||||
printf "@[<1>(%s@ " "Abbrev"; print_quoted_string s; printf ")@]";;
|
||||
|
||||
(* A type definition *)
|
||||
(*
|
||||
requires_widget_context: the converter of the type MUST be passed
|
||||
an additional argument of type Widget.
|
||||
*)
|
||||
let rec print_parser_arity = function
|
||||
| OneToken -> printf "OneToken" | MultipleToken -> printf "MultipleToken";;
|
||||
|
||||
let rec print_type_def = function
|
||||
{parser_arity = p; constructors = l_f; subtypes = l_t_s_l_f;
|
||||
requires_widget_context = b; variant = b0;
|
||||
} ->
|
||||
printf "@[<1>{"; printf "@[<1>parser_arity =@ "; print_parser_arity p;
|
||||
printf ";@]@ "; printf "@[<1>constructors =@ ";
|
||||
print_list print_fullcomponent l_f; printf ";@]@ ";
|
||||
printf "@[<1>subtypes =@ ";
|
||||
print_list
|
||||
(function (s, l_f0) ->
|
||||
printf "@[<1>("; print_quoted_string s; printf ",@ ";
|
||||
print_list print_fullcomponent l_f0; printf ")@]")
|
||||
l_t_s_l_f;
|
||||
printf ";@]@ "; printf "@[<1>requires_widget_context =@ "; print_bool b;
|
||||
printf ";@]@ "; printf "@[<1>variant =@ "; print_bool b0; printf ";@]@ ";
|
||||
printf "@,}@]";;
|
||||
|
||||
let rec print_module_type = function
|
||||
| Widget -> printf "Widget" | Family -> printf "Family";;
|
||||
|
||||
let rec print_module_def = function
|
||||
{module_type = m; commands = l_f; externals = l_f0; } ->
|
||||
printf "@[<1>{"; printf "@[<1>module_type =@ "; print_module_type m;
|
||||
printf ";@]@ "; printf "@[<1>commands =@ ";
|
||||
print_list print_fullcomponent l_f; printf ";@]@ ";
|
||||
printf "@[<1>externals =@ "; print_list print_fullcomponent l_f0;
|
||||
printf ";@]@ "; printf "@,}@]";;
|
||||
Loading…
Reference in New Issue