/[svn]/driver/cduce.ml
ViewVC logotype

Diff of /driver/cduce.ml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 10 by abate, Tue Jul 10 16:57:27 2007 UTC revision 70 by abate, Tue Jul 10 17:03:19 2007 UTC
# Line 1  Line 1 
1  open Location  open Location
2    exception Usage
3    
4    let () =
5      List.iter
6        (fun (n,t) -> Typer.register_global_types [n, mk noloc (Ast.Internal t)])
7        Builtin.types
8    
9    
10    let (source,input_channel) =
11      match Array.length Sys.argv with
12        | 1 -> ("",stdin)
13        | 2 -> let s = Sys.argv.(1) in (s, open_in s)
14        | _ -> raise Usage
15    
16    let () = Location.set_source source
17    
18    let input = Stream.of_channel input_channel
19    
 let input = Stream.of_channel stdin  
20  let ppf = Format.std_formatter  let ppf = Format.std_formatter
21  let prog () =  let prog () =
22    try Parser.prog input    try Parser.prog input
23    with    with
24      | Stdpp.Exc_located (loc, e) ->      | Stdpp.Exc_located (loc, e) -> raise (Location (loc, e))
25          raise (Location (loc, e))  
26    let print_norm ppf d =
27      Types.Print.print_descr ppf ((*Types.normalize*) d)
28    
29  let rec print_exn ppf = function  let rec print_exn ppf = function
30    | Location ((i,j), exn) ->    | Location (loc, exn) ->
31        Format.fprintf ppf "Error at chars %i-%i@\n" i j;        Format.fprintf ppf "Error %a:@\n%a" Location.print_loc loc print_exn exn
32        print_exn ppf exn    | Value.CDuceExn v ->
33          Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@\n"
34            Value.print v
35      | Typer.WrongLabel (t,l) ->
36          Format.fprintf ppf "Wrong record selection: the label %s@\n"
37            (Types.label_name l);
38          Format.fprintf ppf "applied to an expression of type %a@\n"
39            print_norm t
40      | Typer.MultipleLabel l ->
41          Format.fprintf ppf "Multiple occurences for the record label %s@\n"
42            (Types.label_name l);
43      | Typer.ShouldHave (t,msg) ->
44          Format.fprintf ppf "This expression should have type %a@\n%s@\n"
45            print_norm t
46            msg
47    | Typer.Constraint (s,t,msg) ->    | Typer.Constraint (s,t,msg) ->
48        Format.fprintf ppf "%s@\n" msg;        Format.fprintf ppf "This expression should have type %a@\n"
49        Format.fprintf ppf "%a is not a subtype of %a@\n"          print_norm t;
50          Types.Print.print_descr s        Format.fprintf ppf "but its infered type is: %a@\n"
51          Types.Print.print_descr t;          print_norm s;
52        Format.fprintf ppf "as shown by %a@\n"        Format.fprintf ppf "which is not a subtype, as shown by the value %a@\n"
53          Types.Print.print_sample (Types.Sample.get (Types.diff s t))          Types.Print.print_sample (Types.Sample.get (Types.diff s t));
54          Format.fprintf ppf "%s@\n" msg
55      | Typer.NonExhaustive t ->
56          Format.fprintf ppf "This pattern matching is not exhaustive@\n";
57          Format.fprintf ppf "Residual type: %a@\n"
58            print_norm t;
59          Format.fprintf ppf "Sample value: %a@\n"
60            Types.Print.print_sample (Types.Sample.get t)
61      | Typer.UnboundId x ->
62          Format.fprintf ppf "Unbound identifier %s@\n" x
63    | exn ->    | exn ->
64        Format.fprintf ppf "%s@\n" (Printexc.to_string exn)        Format.fprintf ppf "%s@\n" (Printexc.to_string exn)
65    
66    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      | _ -> 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    let insert_type_bindings =
94      List.iter (fun (x,t) ->
95                   typing_env := Typer.Env.add x t !typing_env;
96                   Format.fprintf ppf "|- %s : %a@\n" x print_norm t)
97    
98    let type_decl decl =
99      insert_type_bindings (Typer.type_let_decl !typing_env decl)
100    
101    let eval_decl decl =
102      let bindings = Eval.eval_let_decl !eval_env decl in
103      List.iter
104        (fun (x,v) ->
105           Eval.enter_global x v;
106           Format.fprintf ppf "=> %s : @[%a@]@\n" x Value.print v
107        ) bindings
108    
109  let phrase ph =  let phrase ph =
110    match ph.descr with    match ph.descr with
111      | Ast.EvalStatement e ->      | Ast.EvalStatement e ->
112          let (fv,e) = Typer.expr e in          let (fv,e) = Typer.expr e in
113          let t = Typer.compute_type Typer.Env.empty e in          let t = Typer.type_check !typing_env e Types.any true in
114          Format.fprintf ppf "%a@\n" Types.Print.print_descr t;          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        | Ast.LetDecl (p,{descr=Ast.Abstraction _}) -> ()
118        | Ast.LetDecl (p,e) ->
119            let decl = Typer.let_decl p e in
120            type_decl decl;
121            eval_decl decl
122        | Ast.TypeDecl _ -> ()
123        | Ast.Debug l -> debug l
124      | _ -> assert false      | _ -> assert false
125    
126    let do_fun_decls decls =
127      let decls = List.map (fun (p,e) -> Typer.let_decl p e) decls in
128      insert_type_bindings (Typer.type_rec_funs !typing_env decls);
129      List.iter eval_decl decls
130    
131    
132  let () =  let () =
133    try List.iter phrase (prog ())    try
134    with exn -> print_exn ppf exn      let p = prog () in
135        let (type_decls,fun_decls) =
136          List.fold_left
137            (fun ((typs,funs) as accu) ph -> match ph.descr with
138               | Ast.TypeDecl (x,t) -> ((x,t) :: typs,funs)
139               | Ast.LetDecl (p,({descr=Ast.Abstraction _} as e)) ->
140                   (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    
Legend:
Removed from v.10  
changed lines
  Added in v.70
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5