trunk/compile/print_auto.ml

open Auto_pat
open Ident

let queue = ref []
let printed = Hashtbl.create 1024

let rec_state ppf d =
  Format.fprintf ppf "disp_%i" d.uid;
  queue := d :: !queue

let rec print_source lhs ppf = function
  | Catch  -> Format.fprintf ppf "v"
  | Const c -> Types.Print.print_const ppf c
  | Nil -> Format.fprintf ppf "`nil"
  | Left -> Format.fprintf ppf "v1"
  | Right -> Format.fprintf ppf "v2"
  | Stack i -> Format.fprintf ppf "%s" (List.nth lhs (i-1))
  | Recompose (i,j) -> 
      Format.fprintf ppf "(%s,%s)" 
        (match i with (-1) -> "v1" | (-2) -> "nil" 
           | i -> List.nth lhs (i-1))
        (match j with (-1) -> "v2" | (-2) -> "nil" 
           | j -> List.nth lhs (j-1))
        
let print_result lhs ppf =
  Array.iteri 
    (fun i s ->
       if i > 0 then Format.fprintf ppf ",";
       print_source lhs ppf s; 
    )
    
let print_ret lhs ppf (code,ret,ar) = 
  Format.fprintf ppf "$%i" code;
  if Array.length ret <> 0 then 
    Format.fprintf ppf "(%a)" (print_result lhs) ret
      
let print_ret_opt ppf = function
  | None -> Format.fprintf ppf "*"
  | Some r -> print_ret [] ppf r
      
let gen_lhs prefix d code =
  let arity = d.arity.(code) in
  let r = ref [] in
  for i = 0 to arity - 1 do r := Format.sprintf "%s%i" prefix i :: !r done;
  !r
    
let print_kind ppf actions =
  let print_lhs ppf (code,lhs) =
    Format.fprintf ppf "$%i(" code;
    let rec aux = function
      | [] -> ()
      | [x] -> Format.fprintf ppf "%s" x
      | x::r -> Format.fprintf ppf "%s,x" x; aux r
    in aux lhs;
    Format.fprintf ppf ")" in
  let print_basic (t,ret) =
    Format.fprintf ppf " | %a -> %a@\n"
      Types.Print.print t
      (print_ret []) ret
  in
  let print_prod2 lhs = function
    | Impossible -> assert false
    | Ignore r ->
        Format.fprintf ppf "%a\n" 
          (print_ret lhs) r
    | TailCall d ->
        Format.fprintf ppf "%a v2@\n" rec_state d
    | Dispatch (d, branches) ->
        Format.fprintf ppf "@\n        match %a v2 with@\n" rec_state d;
        Array.iteri 
          (fun code r ->
             let rhs = gen_lhs "r" d code in
             Format.fprintf ppf "        | %a -> %a@\n" 
               print_lhs (code,rhs)
               (print_ret (rhs@lhs)) r;
          )
          branches
  in
  let print_prod prefix ppf = function
    | Impossible -> ()
    | Ignore d2 ->
        Format.fprintf ppf " | %s(v1,v2) -> " prefix;
        print_prod2 [] d2
    | TailCall d ->
        Format.fprintf ppf " | %s(v1,v2) -> %a v1@\n" prefix rec_state d
    | Dispatch (d,branches) ->
        Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;
        Format.fprintf ppf "      match %a v1 with@\n" rec_state d;
        Array.iteri 
          (fun code d2 ->
             let lhs = gen_lhs "l" d code in
             Format.fprintf ppf "      | %a -> " print_lhs (code,lhs);
             print_prod2 lhs d2;
          )
          branches
  in
  let rec print_record_opt ppf = function
    | None -> ()
    | Some (RecLabel (l,d)) ->
        print_prod ("record:"^(Label.string_of_attr l)) ppf d
    | Some (RecNolabel (r1,r2)) ->
        Format.fprintf ppf " | Record -> @\n";
        Format.fprintf ppf "     SomeField:%a;NoField:%a@\n" 
          print_ret_opt r1 print_ret_opt r2
  in
  
  List.iter print_basic actions.basic;
  print_prod "" ppf actions.prod;
  print_prod "XML" ppf actions.xml;
  print_record_opt ppf actions.record
    
let print_actions ppf = function
  | AKind k -> print_kind ppf k
  | AIgnore r -> Format.fprintf ppf "v -> %a@\n" (print_ret []) r

let print_state_opt ppf d =
  if Hashtbl.mem printed d.uid then () 
  else (
    Hashtbl.add printed d.uid ();
    Format.fprintf ppf "State %i = function@\n" d.uid;
    print_actions ppf d.actions;
    Format.fprintf ppf "====================================@."
  )

let print_state ppf d =
  Hashtbl.clear printed;
  queue := [ d ];
  while !queue <> [] do
    let d = List.hd !queue in
    queue := List.tl !queue;
    print_state_opt ppf d
  done;
  Hashtbl.clear printed
 
1	abate	1746	open Auto_pat
2			open Ident
3
4			let queue = ref []
5			let printed = Hashtbl.create 1024
6
7			let rec_state ppf d =
8			Format.fprintf ppf "disp_%i" d.uid;
9			queue := d :: !queue
10
11			let rec print_source lhs ppf = function
12			\| Catch -> Format.fprintf ppf "v"
13			\| Const c -> Types.Print.print_const ppf c
14			\| Nil -> Format.fprintf ppf "`nil"
15			\| Left -> Format.fprintf ppf "v1"
16			\| Right -> Format.fprintf ppf "v2"
17			\| Stack i -> Format.fprintf ppf "%s" (List.nth lhs (i-1))
18			\| Recompose (i,j) ->
19			Format.fprintf ppf "(%s,%s)"
20			(match i with (-1) -> "v1" \| (-2) -> "nil"
21			\| i -> List.nth lhs (i-1))
22			(match j with (-1) -> "v2" \| (-2) -> "nil"
23			\| j -> List.nth lhs (j-1))
24
25			let print_result lhs ppf =
26			Array.iteri
27			(fun i s ->
28			if i > 0 then Format.fprintf ppf ",";
29			print_source lhs ppf s;
30			)
31
32			let print_ret lhs ppf (code,ret,ar) =
33			Format.fprintf ppf "$%i" code;
34			if Array.length ret <> 0 then
35			Format.fprintf ppf "(%a)" (print_result lhs) ret
36
37			let print_ret_opt ppf = function
38			\| None -> Format.fprintf ppf "*"
39			\| Some r -> print_ret [] ppf r
40
41			let gen_lhs prefix d code =
42			let arity = d.arity.(code) in
43			let r = ref [] in
44			for i = 0 to arity - 1 do r := Format.sprintf "%s%i" prefix i :: !r done;
45			!r
46
47			let print_kind ppf actions =
48			let print_lhs ppf (code,lhs) =
49			Format.fprintf ppf "$%i(" code;
50			let rec aux = function
51			\| [] -> ()
52			\| [x] -> Format.fprintf ppf "%s" x
53			\| x::r -> Format.fprintf ppf "%s,x" x; aux r
54			in aux lhs;
55			Format.fprintf ppf ")" in
56			let print_basic (t,ret) =
57			Format.fprintf ppf " \| %a -> %a@\n"
58			Types.Print.print t
59			(print_ret []) ret
60			in
61			let print_prod2 lhs = function
62			\| Impossible -> assert false
63			\| Ignore r ->
64			Format.fprintf ppf "%a\n"
65			(print_ret lhs) r
66			\| TailCall d ->
67			Format.fprintf ppf "%a v2@\n" rec_state d
68			\| Dispatch (d, branches) ->
69			Format.fprintf ppf "@\n match %a v2 with@\n" rec_state d;
70			Array.iteri
71			(fun code r ->
72			let rhs = gen_lhs "r" d code in
73			Format.fprintf ppf " \| %a -> %a@\n"
74			print_lhs (code,rhs)
75			(print_ret (rhs@lhs)) r;
76			)
77			branches
78			in
79			let print_prod prefix ppf = function
80			\| Impossible -> ()
81			\| Ignore d2 ->
82			Format.fprintf ppf " \| %s(v1,v2) -> " prefix;
83			print_prod2 [] d2
84			\| TailCall d ->
85			Format.fprintf ppf " \| %s(v1,v2) -> %a v1@\n" prefix rec_state d
86			\| Dispatch (d,branches) ->
87			Format.fprintf ppf " \| %s(v1,v2) -> @\n" prefix;
88			Format.fprintf ppf " match %a v1 with@\n" rec_state d;
89			Array.iteri
90			(fun code d2 ->
91			let lhs = gen_lhs "l" d code in
92			Format.fprintf ppf " \| %a -> " print_lhs (code,lhs);
93			print_prod2 lhs d2;
94			)
95			branches
96			in
97			let rec print_record_opt ppf = function
98			\| None -> ()
99			\| Some (RecLabel (l,d)) ->
100			print_prod ("record:"^(Label.string_of_attr l)) ppf d
101			\| Some (RecNolabel (r1,r2)) ->
102			Format.fprintf ppf " \| Record -> @\n";
103			Format.fprintf ppf " SomeField:%a;NoField:%a@\n"
104			print_ret_opt r1 print_ret_opt r2
105			in
106
107			List.iter print_basic actions.basic;
108			print_prod "" ppf actions.prod;
109			print_prod "XML" ppf actions.xml;
110			print_record_opt ppf actions.record
111
112			let print_actions ppf = function
113			\| AKind k -> print_kind ppf k
114			\| AIgnore r -> Format.fprintf ppf "v -> %a@\n" (print_ret []) r
115
116			let print_state_opt ppf d =
117			if Hashtbl.mem printed d.uid then ()
118			else (
119			Hashtbl.add printed d.uid ();
120			Format.fprintf ppf "State %i = function@\n" d.uid;
121			print_actions ppf d.actions;
122			Format.fprintf ppf "====================================@."
123			)
124
125			let print_state ppf d =
126			Hashtbl.clear printed;
127			queue := [ d ];
128			while !queue <> [] do
129			let d = List.hd !queue in
130			queue := List.tl !queue;
131			print_state_opt ppf d
132			done;
133			Hashtbl.clear printed
134