cduce.ml 6.1 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
    | _ -> raise Usage

16
17
let () = Location.set_source source

18
let input = Stream.of_channel input_channel
19

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

26
let print_norm ppf d = 
27
  Types.Print.print_descr ppf ((*Types.normalize*) d)
28

29
let rec print_exn ppf = function
30
31
  | Location (loc, exn) ->
      Format.fprintf ppf "Error %a:@\n%a" Location.print_loc loc print_exn exn
32
33
34
  | Value.CDuceExn v ->
      Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@\n"
        Value.print v
35
36
37
  | Typer.WrongLabel (t,l) ->
      Format.fprintf ppf "Wrong record selection: the label %s@\n" 
        (Types.label_name l);
38
      Format.fprintf ppf "applied to an expression of type %a@\n"
39
        print_norm t
40
41
42
  | Typer.MultipleLabel l ->
      Format.fprintf ppf "Multiple occurences for the record label %s@\n"
        (Types.label_name l);
43
44
  | Typer.ShouldHave (t,msg) ->
      Format.fprintf ppf "This expression should have type %a@\n%s@\n" 
45
        print_norm t
46
        msg
47
  | Typer.Constraint (s,t,msg) ->
48
      Format.fprintf ppf "This expression should have type %a@\n" 
49
        print_norm t;
50
      Format.fprintf ppf "but its infered type is: %a@\n" 
51
        print_norm s;
52
      Format.fprintf ppf "which is not a subtype, as shown by the value %a@\n" 
53
	Types.Sample.print (Types.Sample.get (Types.diff s t));
54
      Format.fprintf ppf "%s@\n" msg
55
56
57
  | Typer.NonExhaustive t ->
      Format.fprintf ppf "This pattern matching is not exhaustive@\n";
      Format.fprintf ppf "Residual type: %a@\n"
58
	print_norm t;
59
      Format.fprintf ppf "Sample value: %a@\n" 
60
	Types.Sample.print (Types.Sample.get t)
61
62
  | Typer.UnboundId x ->
      Format.fprintf ppf "Unbound identifier %s@\n" x
63
64
65
  | exn ->
      Format.fprintf ppf "%s@\n" (Printexc.to_string exn)

66
67
68
69
70
71
72
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) ->
73
		   Format.fprintf ppf " %s:%a@\n" x
74
75
76
77
78
79
80
81
82
83
84
85
86
87
		     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
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
  | `Normal_record t ->
      Format.fprintf ppf "[DEBUG:normal_record]@\n";
      let t = Types.descr (Typer.typ t) in
      let count = ref 0 and seen = ref [] in
      match Types.Record.first_label t with
	    | `Empty -> Format.fprintf ppf "Empty"
	    | `Any -> Format.fprintf ppf "Any"
	    | `Label l ->
		let (pr,ab) = Types.Record.normal' t l in
		Format.fprintf ppf "Label (%s,@[" (Types.label_name l);
		List.iter (fun (d,n) ->
			     Format.fprintf ppf "%a => @[%a@];@\n"
			     Types.Print.print_descr d
			     Types.Print.print_descr n
			  ) pr;
		Format.fprintf ppf "@] Absent: @[%a@])@\n" 
		  Types.Print.print_descr 
		  (match ab with Some x -> x | None -> Types.empty)
(*
  | `Normal_record t ->
      Format.fprintf ppf "[DEBUG:normal_record]@\n";
      let t = Types.descr (Typer.typ t) in
      let r = Types.Record.normal t in
      let count = ref 0 and seen = ref [] in
      let rec aux ppf x =
	try 
	  let no = List.assq x !seen in
	  Format.fprintf ppf "[[%i]]" no
	with Not_found ->
	  incr count;
	  seen := (x, !count) :: !seen;
	  Format.fprintf ppf "[[%i]]:" !count;
	  match x with
	    | `Success -> Format.fprintf ppf "Success"
	    | `Fail -> Format.fprintf ppf "Fail"
	    | `Label (l,pr,ab) ->
		Format.fprintf ppf "Label (%s,@[" (Types.label_name l);
		List.iter (fun (d,n) ->
			     Format.fprintf ppf "%a => @[%a@];@\n"
			     Types.Print.print_descr d
			     aux n
			  ) pr;
		Format.fprintf ppf "@] Absent: @[%a@])" aux ab
      in
      Format.fprintf ppf "%a@\n" aux r
*)
134
135

let typing_env = ref Typer.Env.empty
136
let eval_env = ref Eval.Env.empty
137
138
139
140

let insert_type_bindings = 
  List.iter (fun (x,t) ->
	       typing_env := Typer.Env.add x t !typing_env;
141
	       Format.fprintf ppf "|- %s : %a@\n@." x print_norm t)
142
143
144
145
146

let type_decl decl =
  insert_type_bindings (Typer.type_let_decl !typing_env decl)

let eval_decl decl =
147
  let bindings = Eval.eval_let_decl !eval_env decl in
148
149
  List.iter 
    (fun (x,v) ->
150
       Eval.enter_global x v;
151
       Format.fprintf ppf "=> %s : @[%a@]@\n@." x Value.print v
152
153
    ) bindings

154
155
156
157
let phrase ph =
  match ph.descr with
    | Ast.EvalStatement e ->
	let (fv,e) = Typer.expr e in
158
	let t = Typer.type_check !typing_env e Types.any true in
159
	Format.fprintf ppf "|- %a@\n@." print_norm t;
160
	let v = Eval.eval !eval_env e in
161
	Format.fprintf ppf "=> @[%a@]@\n@." Value.print v
162
163
164
165
166
    | Ast.LetDecl (p,{descr=Ast.Abstraction _}) -> ()
    | Ast.LetDecl (p,e) ->
	let decl = Typer.let_decl p e in
	type_decl decl;
	eval_decl decl
167
    | Ast.TypeDecl _ -> ()
168
    | Ast.Debug l -> debug l
169
170
    | _ -> assert false

171
172
173
174
175
176
let do_fun_decls decls =
  let decls = List.map (fun (p,e) -> Typer.let_decl p e) decls in
  insert_type_bindings (Typer.type_rec_funs !typing_env decls);
  List.iter eval_decl decls
 

177
let () = 
178
179
  try 
    let p = prog () in
180
    let (type_decls,fun_decls) = 
181
      List.fold_left
182
183
184
185
	(fun ((typs,funs) as accu) ph -> match ph.descr with
	   | Ast.TypeDecl (x,t) -> ((x,t) :: typs,funs)
	   | Ast.LetDecl (p,({descr=Ast.Abstraction _} as e)) -> 
	       (typs, (p,e)::funs)
186
	   | _ -> accu
187
	) ([],[]) p in
188
    Typer.register_global_types type_decls;
189
    do_fun_decls fun_decls;
190
    List.iter phrase p
191
  with 
192
    | (Failure _ | Not_found | Invalid_argument _) as e -> 
193
	raise e  (* To get the ocamlrun stack trace *)
194
    | exn -> print_exn ppf exn
195
	
196
197
198
199