viewcvs.cgi/driver/cduce.ml

open Location
exception Usage

let () =
  List.iter 
    (fun (n,t) -> Typer.register_global_types [n, mk noloc (Ast.Internal t)])
    Builtin.types


let (source,input_channel) = 
  match Array.length Sys.argv with
    | 1 -> ("",stdin)
    | 2 -> let s = Sys.argv.(1) in (s, open_in s)
    | _ -> raise Usage

let input = Stream.of_channel input_channel

let ppf = Format.std_formatter
let prog () = 
  try Parser.prog input
  with
    | Stdpp.Exc_located (loc, e) -> raise (Location (loc, e))

let print_norm ppf d = 
  Types.Print.print_descr ppf (Types.normalize d)

let rec print_exn ppf = function
  | Location ((i,j), exn) ->
      if source = "" then
        Format.fprintf ppf "Error at chars %i-%i@\n" i j
      else (
        let (l1,c1) = Location.get_line_number source i
        and (l2,c2) = Location.get_line_number source j in
        if l1 = l2 then
          Format.fprintf ppf "Error at line %i (chars %i-%i)@\n"
            l1 c1 c2
        else
          Format.fprintf ppf "Error at lines %i (char %i) - %i (char %i)@\n"
            l1 c1 l2 c2
      );
      print_exn ppf exn
  | Typer.WrongLabel (t,l) ->
      Format.fprintf ppf "Wrong record selection: the label %s@\n" 
        (Types.label_name l);
      Format.fprintf ppf "applied to an expression of type %a@\n"
        print_norm t
  | Typer.MultipleLabel l ->
      Format.fprintf ppf "Multiple occurences for the record label %s@\n"
        (Types.label_name l);
  | Typer.ShouldHave (t,msg) ->
      Format.fprintf ppf "This expression should have type %a@\n%s@\n" 
        print_norm t
        msg
  | Typer.Constraint (s,t,msg) ->
      Format.fprintf ppf "This expression should have type %a@\n" 
        print_norm t;
      Format.fprintf ppf "but its infered type is: %a@\n" 
        print_norm s;
      Format.fprintf ppf "which is not a subtype, as shown by the value %a@\n" 
        Types.Print.print_sample (Types.Sample.get (Types.diff s t));
      Format.fprintf ppf "%s@\n" msg
  | Typer.NonExhaustive t ->
      Format.fprintf ppf "This pattern matching is not exhaustive@\n";
      Format.fprintf ppf "Residual type: %a@\n"
        print_norm t;
      Format.fprintf ppf "Sample value: %a@\n" 
        Types.Print.print_sample (Types.Sample.get t)
  | Typer.UnboundId x ->
      Format.fprintf ppf "Unbound identifier %s@\n" x
  | exn ->
      Format.fprintf ppf "%s@\n" (Printexc.to_string exn)

let debug = function
  | `Filter (t,p) -> 
      Format.fprintf ppf "[DEBUG:filter]@\n";
      let t = Typer.typ t
      and p = Typer.pat p in
      let f = Patterns.filter (Types.descr t) p in
      List.iter (fun (x,t) ->
                   Format.fprintf ppf " x:%a@\n" 
                     print_norm (Types.descr t)) f
  | `Accept p ->
      Format.fprintf ppf "[DEBUG:accept]@\n";
      let p = Typer.pat p in
      let t = Patterns.accept p in
      Format.fprintf ppf " %a@\n" Types.Print.print t
  | `Compile (t,pl) ->
      Format.fprintf ppf "[DEBUG:compile]@\n";
      let t = Typer.typ t
      and pl = List.map Typer.pat pl in
      let pl = Array.of_list 
                 (List.map (fun p -> Patterns.Compile.normal 
                              (Patterns.descr p)) pl) in
      Patterns.Compile.show ppf (Types.descr t) pl
  | _ -> Format.fprintf ppf "Unknown or ill-formed debugging directive !! @\n"
let phrase ph =
  match ph.descr with
    | Ast.EvalStatement e ->
        let (fv,e) = Typer.expr e in
        let t = Typer.type_check Typer.Env.empty e Types.any true in
        Format.fprintf ppf "|- %a@\n" print_norm t;
        let v = Value.eval Value.empty_env e in
        Format.fprintf ppf "=> %a@\n" Value.print v
    | Ast.TypeDecl _ -> ()
    | Ast.Debug l -> debug l
    | _ -> assert false

let () = 
  try 
    let p = prog () in
    let type_decls = 
      List.fold_left
        (fun accu ph -> match ph.descr with
           | Ast.TypeDecl (x,t) -> (x,t) :: accu
           | _ -> accu
        ) [] p in
    Typer.register_global_types type_decls;
    List.iter phrase p
  with 
    | (Failure _ | Not_found) as e -> 
        raise e  (* To get the ocamlrun stack trace *)
    | exn -> print_exn ppf exn
        

1	abate	10	open Location
2	abate	23	exception Usage
3	abate	10
4	abate	18	let () =
5			List.iter
6			(fun (n,t) -> Typer.register_global_types [n, mk noloc (Ast.Internal t)])
7			Builtin.types
8
9	abate	21
10	abate	25	let (source,input_channel) =
11	abate	23	match Array.length Sys.argv with
12	abate	25	\| 1 -> ("",stdin)
13			\| 2 -> let s = Sys.argv.(1) in (s, open_in s)
14	abate	23	\| _ -> raise Usage
15	abate	21
16	abate	23	let input = Stream.of_channel input_channel
17
18	abate	10	let ppf = Format.std_formatter
19			let prog () =
20			try Parser.prog input
21			with
22	abate	21	\| Stdpp.Exc_located (loc, e) -> raise (Location (loc, e))
23	abate	10
24	abate	29	let print_norm ppf d =
25			Types.Print.print_descr ppf (Types.normalize d)
26
27	abate	10	let rec print_exn ppf = function
28			\| Location ((i,j), exn) ->
29	abate	25	if source = "" then
30			Format.fprintf ppf "Error at chars %i-%i@\n" i j
31			else (
32			let (l1,c1) = Location.get_line_number source i
33			and (l2,c2) = Location.get_line_number source j in
34			if l1 = l2 then
35			Format.fprintf ppf "Error at line %i (chars %i-%i)@\n"
36			l1 c1 c2
37			else
38			Format.fprintf ppf "Error at lines %i (char %i) - %i (char %i)@\n"
39			l1 c1 l2 c2
40			);
41	abate	10	print_exn ppf exn
42	abate	26	\| Typer.WrongLabel (t,l) ->
43			Format.fprintf ppf "Wrong record selection: the label %s@\n"
44			(Types.label_name l);
45	abate	27	Format.fprintf ppf "applied to an expression of type %a@\n"
46	abate	29	print_norm t
47	abate	28	\| Typer.MultipleLabel l ->
48			Format.fprintf ppf "Multiple occurences for the record label %s@\n"
49			(Types.label_name l);
50	abate	19	\| Typer.ShouldHave (t,msg) ->
51			Format.fprintf ppf "This expression should have type %a@\n%s@\n"
52	abate	29	print_norm t
53	abate	28	msg
54	abate	10	\| Typer.Constraint (s,t,msg) ->
55	abate	19	Format.fprintf ppf "This expression should have type %a@\n"
56	abate	29	print_norm t;
57	abate	19	Format.fprintf ppf "but its infered type is: %a@\n"
58	abate	29	print_norm s;
59	abate	19	Format.fprintf ppf "which is not a subtype, as shown by the value %a@\n"
60			Types.Print.print_sample (Types.Sample.get (Types.diff s t));
61			Format.fprintf ppf "%s@\n" msg
62	abate	17	\| Typer.NonExhaustive t ->
63			Format.fprintf ppf "This pattern matching is not exhaustive@\n";
64			Format.fprintf ppf "Residual type: %a@\n"
65	abate	29	print_norm t;
66	abate	17	Format.fprintf ppf "Sample value: %a@\n"
67			Types.Print.print_sample (Types.Sample.get t)
68	abate	36	\| Typer.UnboundId x ->
69			Format.fprintf ppf "Unbound identifier %s@\n" x
70	abate	10	\| exn ->
71			Format.fprintf ppf "%s@\n" (Printexc.to_string exn)
72
73	abate	43	let debug = function
74			\| `Filter (t,p) ->
75			Format.fprintf ppf "[DEBUG:filter]@\n";
76			let t = Typer.typ t
77			and p = Typer.pat p in
78			let f = Patterns.filter (Types.descr t) p in
79			List.iter (fun (x,t) ->
80			Format.fprintf ppf " x:%a@\n"
81			print_norm (Types.descr t)) f
82			\| `Accept p ->
83			Format.fprintf ppf "[DEBUG:accept]@\n";
84			let p = Typer.pat p in
85			let t = Patterns.accept p in
86			Format.fprintf ppf " %a@\n" Types.Print.print t
87			\| `Compile (t,pl) ->
88			Format.fprintf ppf "[DEBUG:compile]@\n";
89			let t = Typer.typ t
90			and pl = List.map Typer.pat pl in
91			let pl = Array.of_list
92			(List.map (fun p -> Patterns.Compile.normal
93			(Patterns.descr p)) pl) in
94			Patterns.Compile.show ppf (Types.descr t) pl
95			\| _ -> Format.fprintf ppf "Unknown or ill-formed debugging directive !! @\n"
96	abate	10	let phrase ph =
97			match ph.descr with
98			\| Ast.EvalStatement e ->
99			let (fv,e) = Typer.expr e in
100	abate	19	let t = Typer.type_check Typer.Env.empty e Types.any true in
101	abate	46	Format.fprintf ppf "\|- %a@\n" print_norm t;
102			let v = Value.eval Value.empty_env e in
103			Format.fprintf ppf "=> %a@\n" Value.print v
104	abate	13	\| Ast.TypeDecl _ -> ()
105	abate	43	\| Ast.Debug l -> debug l
106	abate	10	\| _ -> assert false
107
108			let () =
109	abate	13	try
110			let p = prog () in
111			let type_decls =
112			List.fold_left
113			(fun accu ph -> match ph.descr with
114			\| Ast.TypeDecl (x,t) -> (x,t) :: accu
115			\| _ -> accu
116			) [] p in
117			Typer.register_global_types type_decls;
118			List.iter phrase p
119	abate	28	with
120	abate	36	\| (Failure _ \| Not_found) as e ->
121			raise e (* To get the ocamlrun stack trace *)
122	abate	28	\| exn -> print_exn ppf exn
123	abate	10
124	abate	21
125
126
127