cduce.ml 4.68 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
53
54
      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
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
60
      Format.fprintf ppf "Sample value: %a@\n" 
	Types.Print.print_sample (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
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
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"
89
90

let typing_env = ref Typer.Env.empty
91
let eval_env = ref Eval.Env.empty
92
93
94
95
96
97
98
99
100
101

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

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

let eval_decl decl =
102
  let bindings = Eval.eval_let_decl !eval_env decl in
103
104
  List.iter 
    (fun (x,v) ->
105
       Eval.enter_global x v;
106
107
108
       Format.fprintf ppf "=> %s : @[%a@]@\n" x Value.print v
    ) bindings

109
110
111
112
let phrase ph =
  match ph.descr with
    | Ast.EvalStatement e ->
	let (fv,e) = Typer.expr e in
113
	let t = Typer.type_check !typing_env e Types.any true in
114
	Format.fprintf ppf "|- %a@\n" print_norm t;
115
	let v = Eval.eval !eval_env e in
116
	Format.fprintf ppf "=> @[%a@]@\n" Value.print v
117
118
119
120
121
    | Ast.LetDecl (p,{descr=Ast.Abstraction _}) -> ()
    | Ast.LetDecl (p,e) ->
	let decl = Typer.let_decl p e in
	type_decl decl;
	eval_decl decl
122
    | Ast.TypeDecl _ -> ()
123
    | Ast.Debug l -> debug l
124
125
    | _ -> assert false

126
127
128
129
130
131
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
 

132
let () = 
133
134
  try 
    let p = prog () in
135
    let (type_decls,fun_decls) = 
136
      List.fold_left
137
138
139
140
	(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)
141
	   | _ -> accu
142
	) ([],[]) p in
143
    Typer.register_global_types type_decls;
144
    do_fun_decls fun_decls;
145
    List.iter phrase p
146
  with 
147
    | (Failure _ | Not_found | Invalid_argument _) as e -> 
148
	raise e  (* To get the ocamlrun stack trace *)
149
    | exn -> print_exn ppf exn
150
	
151
152
153
154