cduce.ml 3.75 KB
Newer Older
1
open Location
2
exception Usage
3

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

9

10
let (source,input_channel) = 
11
  match Array.length Sys.argv with
12
13
    | 1 -> ("",stdin)
    | 2 -> let s = Sys.argv.(1) in (s, open_in s)
14
15
16
    | _ -> raise Usage

let input = Stream.of_channel input_channel
17

18
19
20
21
let ppf = Format.std_formatter
let prog () = 
  try Parser.prog input
  with
22
    | Stdpp.Exc_located (loc, e) -> raise (Location (loc, e))
23

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

27
28
let rec print_exn ppf = function
  | Location ((i,j), exn) ->
29
30
31
32
33
34
35
36
37
38
39
40
      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
      );
41
      print_exn ppf exn
42
43
44
  | Typer.WrongLabel (t,l) ->
      Format.fprintf ppf "Wrong record selection: the label %s@\n" 
        (Types.label_name l);
45
      Format.fprintf ppf "applied to an expression of type %a@\n"
46
        print_norm t
47
48
49
  | Typer.MultipleLabel l ->
      Format.fprintf ppf "Multiple occurences for the record label %s@\n"
        (Types.label_name l);
50
51
  | Typer.ShouldHave (t,msg) ->
      Format.fprintf ppf "This expression should have type %a@\n%s@\n" 
52
        print_norm t
53
        msg
54
  | Typer.Constraint (s,t,msg) ->
55
      Format.fprintf ppf "This expression should have type %a@\n" 
56
        print_norm t;
57
      Format.fprintf ppf "but its infered type is: %a@\n" 
58
        print_norm s;
59
60
61
      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
62
63
64
  | Typer.NonExhaustive t ->
      Format.fprintf ppf "This pattern matching is not exhaustive@\n";
      Format.fprintf ppf "Residual type: %a@\n"
65
	print_norm t;
66
67
      Format.fprintf ppf "Sample value: %a@\n" 
	Types.Print.print_sample (Types.Sample.get t)
68
69
  | Typer.UnboundId x ->
      Format.fprintf ppf "Unbound identifier %s@\n" x
70
71
72
  | exn ->
      Format.fprintf ppf "%s@\n" (Printexc.to_string exn)

73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
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"
96
97
98
99
let phrase ph =
  match ph.descr with
    | Ast.EvalStatement e ->
	let (fv,e) = Typer.expr e in
100
	let t = Typer.type_check Typer.Env.empty e Types.any true in
101
	Format.fprintf ppf "%a@\n" print_norm t
102
    | Ast.TypeDecl _ -> ()
103
    | Ast.Debug l -> debug l
104
105
106
    | _ -> assert false

let () = 
107
108
109
110
111
112
113
114
115
116
  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
117
  with 
118
119
    | (Failure _ | Not_found) as e -> 
	raise e  (* To get the ocamlrun stack trace *)
120
    | exn -> print_exn ppf exn
121
	
122
123
124
125