cduce.ml 6.39 KB
Newer Older
1
open Location
2
open Ident
3

4
5
let quiet = ref false

6
7
let typing_env = State.ref "Cduce.typing_env" Typer.Env.empty

8
let print_norm ppf d = 
9
  Location.protect ppf 
10
    (fun ppf -> Types.Print.print_descr ppf ((*Types.normalize*) d))
11
12
13

let print_value ppf v =
  Location.protect ppf (fun ppf -> Value.print ppf v)
14

15
let dump_env ppf =
16
17
18
  Format.fprintf ppf "Global types:";
  Typer.dump_global_types ppf;
  Format.fprintf ppf ".@\n";
19
20
21
22
  Eval.Env.iter 
    (fun x v ->
       let t = Typer.Env.find x !typing_env in
       Format.fprintf ppf "@[|- %s : %a@ => %a@]@\n"
23
	 (Id.value x)
24
25
26
	 print_norm t
	 print_value v
    )
27
    !Eval.global_env
28
29
  

30
let rec print_exn ppf = function
31
  | Location (loc, exn) ->
32
      Format.fprintf ppf "Error %a:@\n" Location.print_loc loc;
33
      Format.fprintf ppf "%a" Location.html_hilight loc;
34
      print_exn ppf exn
35
36
  | Value.CDuceExn v ->
      Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@\n"
37
        print_value v
38
39
  | Typer.WrongLabel (t,l) ->
      Format.fprintf ppf "Wrong record selection: the label %s@\n" 
40
        (LabelPool.value l);
41
      Format.fprintf ppf "applied to an expression of type %a@\n"
42
        print_norm t
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
66
67
68
69
70
  | 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"
71
  | Parser.Error s | Stream.Error s -> 
72
      Format.fprintf ppf "Parsing error: %s@\n" s
73
74
  | Location.Generic s ->
      Format.fprintf ppf "%s@\n" s
75
  | exn ->
76
77
      raise exn
(*
78
      Format.fprintf ppf "%s@\n" (Printexc.to_string exn)
79
*)
80

81
let debug ppf = function
82
83
  | `Subtype (t1,t2) ->
      Format.fprintf ppf "[DEBUG:subtype]@\n";
84
85
      let t1 = Types.descr (Typer.typ t1)
      and t2 = Types.descr (Typer.typ t2) in
86
87
      Format.fprintf ppf "%a <= %a : %b@\n" print_norm t1 print_norm t2
	(Types.subtype t1 t2)
88
89
  | `Filter (t,p) -> 
      Format.fprintf ppf "[DEBUG:filter]@\n";
90
91
      let t = Typer.typ t
      and p = Typer.pat p in
92
93
      let f = Patterns.filter (Types.descr t) p in
      List.iter (fun (x,t) ->
94
		   Format.fprintf ppf " %s:%a@\n" (Id.value x)
95
		     print_norm (Types.descr t)) f
96
97
  | `Compile2 (t,pl) -> 
      Format.fprintf ppf "[DEBUG:compile2]@\n";
98
(*      let t = Types.descr (Typer.typ t) in
99
      let pl = List.map (fun p -> 
100
			   let p = Typer.pat p in
101
102
103
104
105
			   let a = Types.descr (Patterns.accept p) in
			   (Some p, Types.cap a t)) pl in
      let d = Patterns.Compiler.make_dispatcher t pl in
      Patterns.Compiler.print_disp ppf d *)
      ()
106

107
108
  | `Accept p ->
      Format.fprintf ppf "[DEBUG:accept]@\n";
109
      let p = Typer.pat p in
110
111
112
113
      let t = Patterns.accept p in
      Format.fprintf ppf " %a@\n" Types.Print.print t
  | `Compile (t,pl) ->
      Format.fprintf ppf "[DEBUG:compile]@\n";
114
115
      let t = Typer.typ t
      and pl = List.map Typer.pat pl in
116
      Patterns.Compile.debug_compile ppf t pl
117
  | `Normal_record p -> assert false
118
119


120

121
let mk_builtin () =
122
  let bi = List.map (fun (n,t) -> [n, mknoloc (Ast.Internal t)]) 
123
	     Builtin.types in
124
  List.iter Typer.register_global_types bi
125

126
127
128
let () = mk_builtin ()


129
let run ppf ppf_err input =
130
131
132
  let insert_type_bindings = 
    List.iter (fun (x,t) ->
		 typing_env := Typer.Env.add x t !typing_env;
133
		 if not !quiet then
134
		   Format.fprintf ppf "|- %s : %a@\n@." (Id.value x) print_norm t) 
135
136
137
138
139
140
141
  in
  
  let type_decl decl =
    insert_type_bindings (Typer.type_let_decl !typing_env decl)
  in

  let eval_decl decl =
142
    let bindings = Eval.eval_let_decl Eval.Env.empty decl in
143
144
145
    List.iter 
      (fun (x,v) ->
	 Eval.enter_global x v;
146
	 if not !quiet then
147
	   Format.fprintf ppf "=> %s : @[%a@]@\n@." (Id.value x) print_value v
148
149
150
      ) bindings
  in

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

  let do_fun_decls decls =
173
    let decls = List.map (fun (p,e) -> Typer.let_decl p e) decls in
174
175
176
    insert_type_bindings (Typer.type_rec_funs !typing_env decls);
    List.iter eval_decl decls
  in
177
178
179
180
181
182
183
184
185
186
  let rec phrases funs = function
    | { descr = Ast.LetDecl (p,({descr=Ast.Abstraction _} as e))} :: phs -> 
	phrases ((p,e)::funs) phs
    | ph :: phs ->
	do_fun_decls funs;
	phrase ph;
	phrases [] phs
    | _ ->
	do_fun_decls funs
  in
187
  try 
188
189
190
191
    let p = 
      try Parser.prog input
      with
	| Stdpp.Exc_located (_, (Location _ as e)) -> raise e
192
	| Stdpp.Exc_located ((i,j), e) -> raise_loc i j e
193
    in
194
    let (type_decls,fun_decls) = 
195
      List.fold_left
196
197
198
199
	(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)
200
	   | _ -> accu
201
	) ([],[]) p in
202
    Typer.register_global_types type_decls;
203
    phrases [] p;
204
    true
205
  with 
206
    | (Failure _ | Not_found | Invalid_argument _) as e -> 
207
	raise e  (* To get ocamlrun stack trace *)
208
    | exn -> print_exn ppf_err exn; false
209
	
210