cduce.ml 6.64 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 (_, (Location _ as e)) -> raise e
25
    | Stdpp.Exc_located (loc, e) -> raise (Location (loc, e))
26

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

30
let rec print_exn ppf = function
31
32
  | Location (loc, exn) ->
      Format.fprintf ppf "Error %a:@\n%a" Location.print_loc loc print_exn exn
33
34
35
  | Value.CDuceExn v ->
      Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@\n"
        Value.print v
36
37
  | Typer.WrongLabel (t,l) ->
      Format.fprintf ppf "Wrong record selection: the label %s@\n" 
38
        (Types.LabelPool.value l);
39
      Format.fprintf ppf "applied to an expression of type %a@\n"
40
        print_norm t
41
42
  | Typer.MultipleLabel l ->
      Format.fprintf ppf "Multiple occurences for the record label %s@\n"
43
        (Types.LabelPool.value l);
44
45
  | Typer.ShouldHave (t,msg) ->
      Format.fprintf ppf "This expression should have type %a@\n%s@\n" 
46
        print_norm t
47
        msg
48
  | Typer.Constraint (s,t,msg) ->
49
      Format.fprintf ppf "This expression should have type %a@\n" 
50
        print_norm t;
51
      Format.fprintf ppf "but its infered type is: %a@\n" 
52
        print_norm s;
53
      Format.fprintf ppf "which is not a subtype, as shown by the value %a@\n" 
54
	Types.Sample.print (Types.Sample.get (Types.diff s t));
55
      Format.fprintf ppf "%s@\n" msg
56
57
58
  | Typer.NonExhaustive t ->
      Format.fprintf ppf "This pattern matching is not exhaustive@\n";
      Format.fprintf ppf "Residual type: %a@\n"
59
	print_norm t;
60
      Format.fprintf ppf "Sample value: %a@\n" 
61
	Types.Sample.print (Types.Sample.get t)
62
63
  | Typer.UnboundId x ->
      Format.fprintf ppf "Unbound identifier %s@\n" x
64
65
66
67
68
69
70
71
72
73
  | Wlexer.Illegal_character c ->
      Format.fprintf ppf "Illegal character (%s)@\n" (Char.escaped c)
  | Wlexer.Unterminated_comment ->
      Format.fprintf ppf "Comment not terminated@\n"
  | Wlexer.Unterminated_string ->
      Format.fprintf ppf "String literal not terminated@\n"
  | Wlexer.Unterminated_string_in_comment ->
      Format.fprintf ppf "This comment contains an unterminated string literal@\n"
  | Parser.Error s ->
      Format.fprintf ppf "Parsing error: %s@\n" s
74
75
76
  | exn ->
      Format.fprintf ppf "%s@\n" (Printexc.to_string exn)

77
78
79
80
81
82
83
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) ->
84
		   Format.fprintf ppf " %s:%a@\n" x
85
86
87
88
89
90
91
92
93
94
95
96
97
98
		     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
99
100
101
102
103
104
105
106
107
  | `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
108
		Format.fprintf ppf "Label (%s,@[" (Types.LabelPool.value l);
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
134
135
136
137
138
139
140
141
142
143
144
		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
*)
145
146

let typing_env = ref Typer.Env.empty
147
let eval_env = ref Eval.Env.empty
148
149
150
151

let insert_type_bindings = 
  List.iter (fun (x,t) ->
	       typing_env := Typer.Env.add x t !typing_env;
152
	       Format.fprintf ppf "|- %s : %a@\n@." x print_norm t)
153
154
155
156
157

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

let eval_decl decl =
158
  let bindings = Eval.eval_let_decl !eval_env decl in
159
160
  List.iter 
    (fun (x,v) ->
161
       Eval.enter_global x v;
162
       Format.fprintf ppf "=> %s : @[%a@]@\n@." x Value.print v
163
164
    ) bindings

165
166
167
168
let phrase ph =
  match ph.descr with
    | Ast.EvalStatement e ->
	let (fv,e) = Typer.expr e in
169
	let t = Typer.type_check !typing_env e Types.any true in
170
	Format.fprintf ppf "|- %a@\n@." print_norm t;
171
	let v = Eval.eval !eval_env e in
172
	Format.fprintf ppf "=> @[%a@]@\n@." Value.print v
173
174
175
176
177
    | Ast.LetDecl (p,{descr=Ast.Abstraction _}) -> ()
    | Ast.LetDecl (p,e) ->
	let decl = Typer.let_decl p e in
	type_decl decl;
	eval_decl decl
178
    | Ast.TypeDecl _ -> ()
179
    | Ast.Debug l -> debug l
180
181
    | _ -> assert false

182
183
184
185
186
187
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
 

188
let () = 
189
190
  try 
    let p = prog () in
191
    let (type_decls,fun_decls) = 
192
      List.fold_left
193
194
195
196
	(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)
197
	   | _ -> accu
198
	) ([],[]) p in
199
    Typer.register_global_types type_decls;
200
    do_fun_decls fun_decls;
201
    List.iter phrase p
202
  with 
203
    | (Failure _ | Not_found | Invalid_argument _) as e -> 
204
	raise e  (* To get the ocamlrun stack trace *)
205
    | exn -> print_exn ppf exn
206
	
207
208
209
210