[r2005-02-21 07:15:03 by afrisch] Empty log message

Original author: afrisch
Date: 2005-02-21 07:15:04+00:00

misc/stats.ml

@@ -60,3 +60,34 @@ module Counter = struct
   let incr c =
     c.count <- c.count + 1
 end
+
+
+module InOut = struct
+  let h = Hashtbl.create 17
+
+  let enter s =
+    let i = try Hashtbl.find h s with Not_found ->
+      let r = ref 0 in
+      Hashtbl.add h s r;
+      r in
+    incr i;
+    Printf.printf "+%s[%i] " s !i;
+    flush stdout
+
+  let leave s =
+    let i = try Hashtbl.find h s with Not_found -> assert false in
+    decr i;
+    Printf.printf "-%s[%i] " s !i;
+    flush stdout
+
+  let wrap s f x =
+    enter s;
+    try
+      let r = f x in
+      leave s;
+      r
+    with exn ->
+      leave s;
+      raise exn
+    
+end

misc/stats.mli

@@ -20,3 +20,10 @@ module Timer: sig
   val stop: t -> 'a -> 'a
   val print: Format.formatter -> t -> unit
 end
+
+
+module InOut: sig
+  val enter: string -> unit
+  val leave: string -> unit
+  val wrap: string -> ('a -> 'b) -> 'a -> 'b
+end

schema/schema_common.ml

@@ -214,7 +214,7 @@ let print_element fmt { elt_uid = id; elt_name = name } =
 let print_attributes fmt = List.iter (Format.fprintf fmt "%a" print_attribute)
 let print_attribute_group fmt ag =
   Format.fprintf fmt "{agroup:%a}" Ns.QName.print ag.ag_name
-let print_model_group fmt mg =
+let print_model_group_def fmt mg =
   Format.fprintf fmt "{mgroup:%a}" Ns.QName.print mg.mg_name
 let print_schema fmt schema =
   let defined_types = (* filter out built-in types *)
@@ -248,7 +248,7 @@ let print_schema fmt schema =
   end;
   if schema.model_groups <> [] then begin
     Format.fprintf fmt "Model groups: ";
-    List.iter (fun c -> print_model_group fmt c; Format.fprintf fmt " ")
+    List.iter (fun c -> print_model_group_def fmt c; Format.fprintf fmt " ")
       schema.model_groups;
     Format.fprintf fmt "\n"
   end
@@ -421,3 +421,17 @@ let test v =
   aux ()
 *)
 
+
+let rec print_model_group ppf = function
+  | All pl -> Format.fprintf ppf "All(%a)" print_particle_list pl
+  | Choice pl -> Format.fprintf ppf "Choice(%a)" print_particle_list pl
+  | Sequence pl -> Format.fprintf ppf "Sequence(%a)" print_particle_list pl
+and print_particle_list ppf = function
+  | [] -> ()
+  | [p] -> print_particle ppf p
+  | hd::tl -> Format.fprintf ppf "%a;%a" print_particle hd print_particle_list tl
+and print_particle ppf (min,max,term,_) =
+  print_term ppf term
+and print_term ppf = function
+  | Elt e -> Format.fprintf ppf "E%i" ((Lazy.force e).elt_uid)
+  | Model m -> print_model_group ppf m

schema/schema_common.mli

@@ -17,7 +17,7 @@ val print_attribute : Format.formatter -> attribute_declaration -> unit
 val print_element : Format.formatter -> element_declaration -> unit
 val print_attribute_group :
   Format.formatter -> attribute_group_definition -> unit
-val print_model_group : Format.formatter -> model_group_definition -> unit
+val print_model_group_def : Format.formatter -> model_group_definition -> unit
 val print_simple_type : Format.formatter -> simple_type_definition -> unit
 val print_complex_type : Format.formatter -> complex_type_definition -> unit
 
@@ -93,3 +93,7 @@ val normalize_white_space: white_space_handling -> Utf8.t -> Utf8.t
 val stream_of_value: Value.t -> event Stream.t
 val string_of_event: event -> string
 
+
+
+val print_model_group: Format.formatter -> model_group -> unit
+val print_particle: Format.formatter -> particle -> unit