viewcvs.cgi/driver/cduce.ml

open Location
exception Usage

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


let (source,input_channel) = 
  match Array.length Sys.argv with
    | 1 -> ("",stdin)
    | 2 -> let s = Sys.argv.(1) in (s, open_in s)
    | _ -> raise Usage

let () = Location.set_source source

let input = Stream.of_channel input_channel

let ppf = Format.std_formatter
let prog () = 
  try Parser.prog input
  with
    | Stdpp.Exc_located (loc, e) -> raise (Location (loc, e))

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

let rec print_exn ppf = function
  | Location (loc, exn) ->
      Format.fprintf ppf "Error %a:@\n%a" Location.print_loc loc print_exn exn
  | Value.CDuceExn v ->
      Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@\n"
        Value.print v
  | Typer.WrongLabel (t,l) ->
      Format.fprintf ppf "Wrong record selection: the label %s@\n" 
        (Types.label_name l);
      Format.fprintf ppf "applied to an expression of type %a@\n"
        print_norm t
  | Typer.MultipleLabel l ->
      Format.fprintf ppf "Multiple occurences for the record label %s@\n"
        (Types.label_name l);
  | Typer.ShouldHave (t,msg) ->
      Format.fprintf ppf "This expression should have type %a@\n%s@\n" 
        print_norm t
        msg
  | Typer.Constraint (s,t,msg) ->
      Format.fprintf ppf "This expression should have type %a@\n" 
        print_norm t;
      Format.fprintf ppf "but its infered type is: %a@\n" 
        print_norm s;
      Format.fprintf ppf "which is not a subtype, as shown by the value %a@\n" 
        Types.Sample.print (Types.Sample.get (Types.diff s t));
      Format.fprintf ppf "%s@\n" msg
  | Typer.NonExhaustive t ->
      Format.fprintf ppf "This pattern matching is not exhaustive@\n";
      Format.fprintf ppf "Residual type: %a@\n"
        print_norm t;
      Format.fprintf ppf "Sample value: %a@\n" 
        Types.Sample.print (Types.Sample.get t)
  | Typer.UnboundId x ->
      Format.fprintf ppf "Unbound identifier %s@\n" x
  | exn ->
      Format.fprintf ppf "%s@\n" (Printexc.to_string exn)

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
  | `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
*)

let typing_env = ref Typer.Env.empty
let eval_env = ref Eval.Env.empty

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 =
  let bindings = Eval.eval_let_decl !eval_env decl in
  List.iter 
    (fun (x,v) ->
       Eval.enter_global x v;
       Format.fprintf ppf "=> %s : @[%a@]@\n@." x Value.print v
    ) bindings

let phrase ph =
  match ph.descr with
    | Ast.EvalStatement e ->
        let (fv,e) = Typer.expr e in
        let t = Typer.type_check !typing_env e Types.any true in
        Format.fprintf ppf "|- %a@\n@." print_norm t;
        let v = Eval.eval !eval_env e in
        Format.fprintf ppf "=> @[%a@]@\n@." Value.print v
    | Ast.LetDecl (p,{descr=Ast.Abstraction _}) -> ()
    | Ast.LetDecl (p,e) ->
        let decl = Typer.let_decl p e in
        type_decl decl;
        eval_decl decl
    | Ast.TypeDecl _ -> ()
    | Ast.Debug l -> debug l
    | _ -> assert false

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
 

let () = 
  try 
    let p = prog () in
    let (type_decls,fun_decls) = 
      List.fold_left
        (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)
           | _ -> accu
        ) ([],[]) p in
    Typer.register_global_types type_decls;
    do_fun_decls fun_decls;
    List.iter phrase p
  with 
    | (Failure _ | Not_found | Invalid_argument _) as e -> 
        raise e  (* To get the ocamlrun stack trace *)
    | exn -> print_exn ppf exn
        

1	abate	10	open Location
2	abate	23	exception Usage
3	abate	10
4	abate	18	let () =
5			List.iter
6			(fun (n,t) -> Typer.register_global_types [n, mk noloc (Ast.Internal t)])
7			Builtin.types
8
9	abate	21
10	abate	25	let (source,input_channel) =
11	abate	23	match Array.length Sys.argv with
12	abate	25	\| 1 -> ("",stdin)
13			\| 2 -> let s = Sys.argv.(1) in (s, open_in s)
14	abate	23	\| _ -> raise Usage
15	abate	21
16	abate	66	let () = Location.set_source source
17
18	abate	23	let input = Stream.of_channel input_channel
19
20	abate	10	let ppf = Format.std_formatter
21			let prog () =
22			try Parser.prog input
23			with
24	abate	21	\| Stdpp.Exc_located (loc, e) -> raise (Location (loc, e))
25	abate	10
26	abate	29	let print_norm ppf d =
27	abate	67	Types.Print.print_descr ppf ((Types.normalize) d)
28	abate	29
29	abate	10	let rec print_exn ppf = function
30	abate	66	\| Location (loc, exn) ->
31			Format.fprintf ppf "Error %a:@\n%a" Location.print_loc loc print_exn exn
32	abate	64	\| Value.CDuceExn v ->
33			Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@\n"
34			Value.print v
35	abate	26	\| Typer.WrongLabel (t,l) ->
36			Format.fprintf ppf "Wrong record selection: the label %s@\n"
37			(Types.label_name l);
38	abate	27	Format.fprintf ppf "applied to an expression of type %a@\n"
39	abate	29	print_norm t
40	abate	28	\| Typer.MultipleLabel l ->
41			Format.fprintf ppf "Multiple occurences for the record label %s@\n"
42			(Types.label_name l);
43	abate	19	\| Typer.ShouldHave (t,msg) ->
44			Format.fprintf ppf "This expression should have type %a@\n%s@\n"
45	abate	29	print_norm t
46	abate	28	msg
47	abate	10	\| Typer.Constraint (s,t,msg) ->
48	abate	19	Format.fprintf ppf "This expression should have type %a@\n"
49	abate	29	print_norm t;
50	abate	19	Format.fprintf ppf "but its infered type is: %a@\n"
51	abate	29	print_norm s;
52	abate	19	Format.fprintf ppf "which is not a subtype, as shown by the value %a@\n"
53	abate	71	Types.Sample.print (Types.Sample.get (Types.diff s t));
54	abate	19	Format.fprintf ppf "%s@\n" msg
55	abate	17	\| Typer.NonExhaustive t ->
56			Format.fprintf ppf "This pattern matching is not exhaustive@\n";
57			Format.fprintf ppf "Residual type: %a@\n"
58	abate	29	print_norm t;
59	abate	17	Format.fprintf ppf "Sample value: %a@\n"
60	abate	71	Types.Sample.print (Types.Sample.get t)
61	abate	36	\| Typer.UnboundId x ->
62			Format.fprintf ppf "Unbound identifier %s@\n" x
63	abate	10	\| exn ->
64			Format.fprintf ppf "%s@\n" (Printexc.to_string exn)
65
66	abate	43	let debug = function
67			\| `Filter (t,p) ->
68			Format.fprintf ppf "[DEBUG:filter]@\n";
69			let t = Typer.typ t
70			and p = Typer.pat p in
71			let f = Patterns.filter (Types.descr t) p in
72			List.iter (fun (x,t) ->
73			Format.fprintf ppf " x:%a@\n"
74			print_norm (Types.descr t)) f
75			\| `Accept p ->
76			Format.fprintf ppf "[DEBUG:accept]@\n";
77			let p = Typer.pat p in
78			let t = Patterns.accept p in
79			Format.fprintf ppf " %a@\n" Types.Print.print t
80			\| `Compile (t,pl) ->
81			Format.fprintf ppf "[DEBUG:compile]@\n";
82			let t = Typer.typ t
83			and pl = List.map Typer.pat pl in
84			let pl = Array.of_list
85			(List.map (fun p -> Patterns.Compile.normal
86			(Patterns.descr p)) pl) in
87			Patterns.Compile.show ppf (Types.descr t) pl
88	abate	75	\| `Normal_record t ->
89			Format.fprintf ppf "[DEBUG:normal_record]@\n";
90			let t = Types.descr (Typer.typ t) in
91			let count = ref 0 and seen = ref [] in
92			match Types.Record.first_label t with
93			\| `Empty -> Format.fprintf ppf "Empty"
94			\| `Any -> Format.fprintf ppf "Any"
95			\| `Label l ->
96			let (pr,ab) = Types.Record.normal' t l in
97			Format.fprintf ppf "Label (%s,@[" (Types.label_name l);
98			List.iter (fun (d,n) ->
99			Format.fprintf ppf "%a => @[%a@];@\n"
100			Types.Print.print_descr d
101			Types.Print.print_descr n
102			) pr;
103			Format.fprintf ppf "@] Absent: @[%a@])@\n"
104			Types.Print.print_descr
105			(match ab with Some x -> x \| None -> Types.empty)
106			(*
107			\| `Normal_record t ->
108			Format.fprintf ppf "[DEBUG:normal_record]@\n";
109			let t = Types.descr (Typer.typ t) in
110			let r = Types.Record.normal t in
111			let count = ref 0 and seen = ref [] in
112			let rec aux ppf x =
113			try
114			let no = List.assq x !seen in
115			Format.fprintf ppf "[[%i]]" no
116			with Not_found ->
117			incr count;
118			seen := (x, !count) :: !seen;
119			Format.fprintf ppf "[[%i]]:" !count;
120			match x with
121			\| `Success -> Format.fprintf ppf "Success"
122			\| `Fail -> Format.fprintf ppf "Fail"
123			\| `Label (l,pr,ab) ->
124			Format.fprintf ppf "Label (%s,@[" (Types.label_name l);
125			List.iter (fun (d,n) ->
126			Format.fprintf ppf "%a => @[%a@];@\n"
127			Types.Print.print_descr d
128			aux n
129			) pr;
130			Format.fprintf ppf "@] Absent: @[%a@])" aux ab
131			in
132			Format.fprintf ppf "%a@\n" aux r
133			*)
134	abate	66
135			let typing_env = ref Typer.Env.empty
136	abate	70	let eval_env = ref Eval.Env.empty
137	abate	66
138			let insert_type_bindings =
139			List.iter (fun (x,t) ->
140			typing_env := Typer.Env.add x t !typing_env;
141	abate	71	Format.fprintf ppf "\|- %s : %a@\n@." x print_norm t)
142	abate	66
143			let type_decl decl =
144			insert_type_bindings (Typer.type_let_decl !typing_env decl)
145
146			let eval_decl decl =
147	abate	70	let bindings = Eval.eval_let_decl !eval_env decl in
148	abate	66	List.iter
149			(fun (x,v) ->
150	abate	70	Eval.enter_global x v;
151	abate	71	Format.fprintf ppf "=> %s : @[%a@]@\n@." x Value.print v
152	abate	66	) bindings
153
154	abate	10	let phrase ph =
155			match ph.descr with
156			\| Ast.EvalStatement e ->
157			let (fv,e) = Typer.expr e in
158	abate	66	let t = Typer.type_check !typing_env e Types.any true in
159	abate	71	Format.fprintf ppf "\|- %a@\n@." print_norm t;
160	abate	70	let v = Eval.eval !eval_env e in
161	abate	71	Format.fprintf ppf "=> @[%a@]@\n@." Value.print v
162	abate	66	\| Ast.LetDecl (p,{descr=Ast.Abstraction _}) -> ()
163			\| Ast.LetDecl (p,e) ->
164			let decl = Typer.let_decl p e in
165			type_decl decl;
166			eval_decl decl
167	abate	13	\| Ast.TypeDecl _ -> ()
168	abate	43	\| Ast.Debug l -> debug l
169	abate	10	\| _ -> assert false
170
171	abate	66	let do_fun_decls decls =
172			let decls = List.map (fun (p,e) -> Typer.let_decl p e) decls in
173			insert_type_bindings (Typer.type_rec_funs !typing_env decls);
174			List.iter eval_decl decls
175
176
177	abate	10	let () =
178	abate	13	try
179			let p = prog () in
180	abate	66	let (type_decls,fun_decls) =
181	abate	13	List.fold_left
182	abate	66	(fun ((typs,funs) as accu) ph -> match ph.descr with
183			\| Ast.TypeDecl (x,t) -> ((x,t) :: typs,funs)
184			\| Ast.LetDecl (p,({descr=Ast.Abstraction _} as e)) ->
185			(typs, (p,e)::funs)
186	abate	13	\| _ -> accu
187	abate	66	) ([],[]) p in
188	abate	13	Typer.register_global_types type_decls;
189	abate	66	do_fun_decls fun_decls;
190	abate	13	List.iter phrase p
191	abate	28	with
192	abate	57	\| (Failure _ \| Not_found \| Invalid_argument _) as e ->
193	abate	36	raise e (* To get the ocamlrun stack trace *)
194	abate	28	\| exn -> print_exn ppf exn
195	abate	10
196	abate	21
197
198
199