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

Diff of /driver/cduce.ml

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

revision 19 by abate, Tue Jul 10 16:58:37 2007 UTC revision 124 by abate, Tue Jul 10 17:08:19 2007 UTC
# Line 1  Line 1 
1  open Location  open Location
2    
3  let () =  let typing_env = State.ref "Cduce.typing_env" Typer.Env.empty
4    List.iter  let glb_env = State.ref "Cduce.glb_env" Typer.Env.empty
5      (fun (n,t) -> Typer.register_global_types [n, mk noloc (Ast.Internal t)])  let eval_env = Eval.global_env
6      Builtin.types  
7    let print_norm ppf d =
8      Location.protect ppf
9        (fun ppf -> Types.Print.print_descr ppf ((*Types.normalize*) d))
10    
11    let print_value ppf v =
12      Location.protect ppf (fun ppf -> Value.print ppf v)
13    
14    let dump_env ppf =
15      Format.fprintf ppf "Global types:";
16      Typer.Env.iter (fun x _ -> Format.fprintf ppf " %s" x) !glb_env;
17      Format.fprintf ppf ".@\n";
18      Eval.Env.iter
19        (fun x v ->
20           let t = Typer.Env.find x !typing_env in
21           Format.fprintf ppf "@[|- %s : %a@ => %a@]@\n"
22             x
23             print_norm t
24             print_value v
25        )
26        !eval_env
27    
 let input = Stream.of_channel stdin  
 let ppf = Format.std_formatter  
 let prog () =  
   try Parser.prog input  
   with  
     | Stdpp.Exc_located (loc, e) ->  
         raise (Location (loc, e))  
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" Location.print_loc loc;
32          Format.fprintf ppf "%a" Location.html_hilight loc;
33        print_exn ppf exn        print_exn ppf exn
34      | Value.CDuceExn v ->
35          Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@\n"
36            print_value v
37      | Typer.WrongLabel (t,l) ->
38          Format.fprintf ppf "Wrong record selection: the label %s@\n"
39            (Types.LabelPool.value l);
40          Format.fprintf ppf "applied to an expression of type %a@\n"
41            print_norm t
42      | Typer.MultipleLabel l ->
43          Format.fprintf ppf "Multiple occurences for the record label %s@\n"
44            (Types.LabelPool.value l);
45    | Typer.ShouldHave (t,msg) ->    | Typer.ShouldHave (t,msg) ->
46        Format.fprintf ppf "This expression should have type %a@\n%s@\n"        Format.fprintf ppf "This expression should have type %a@\n%s@\n"
47          Types.Print.print_descr t          print_norm t
48        msg        msg
49    | Typer.Constraint (s,t,msg) ->    | Typer.Constraint (s,t,msg) ->
50        Format.fprintf ppf "This expression should have type %a@\n"        Format.fprintf ppf "This expression should have type %a@\n"
51          Types.Print.print_descr t;          print_norm t;
52        Format.fprintf ppf "but its infered type is: %a@\n"        Format.fprintf ppf "but its infered type is: %a@\n"
53          Types.Print.print_descr s;          print_norm s;
54        Format.fprintf ppf "which is not a subtype, as shown by the value %a@\n"        Format.fprintf ppf "which is not a subtype, as shown by the value %a@\n"
55          Types.Print.print_sample (Types.Sample.get (Types.diff s t));          Types.Sample.print (Types.Sample.get (Types.diff s t));
56        Format.fprintf ppf "%s@\n" msg        Format.fprintf ppf "%s@\n" msg
57    | Typer.NonExhaustive t ->    | Typer.NonExhaustive t ->
58        Format.fprintf ppf "This pattern matching is not exhaustive@\n";        Format.fprintf ppf "This pattern matching is not exhaustive@\n";
59        Format.fprintf ppf "Residual type: %a@\n"        Format.fprintf ppf "Residual type: %a@\n"
60          Types.Print.print_descr t;          print_norm t;
61        Format.fprintf ppf "Sample value: %a@\n"        Format.fprintf ppf "Sample value: %a@\n"
62          Types.Print.print_sample (Types.Sample.get t)          Types.Sample.print (Types.Sample.get t)
63      | Typer.UnboundId x ->
64          Format.fprintf ppf "Unbound identifier %s@\n" x
65      | Wlexer.Illegal_character c ->
66          Format.fprintf ppf "Illegal character (%s)@\n" (Char.escaped c)
67      | Wlexer.Unterminated_comment ->
68          Format.fprintf ppf "Comment not terminated@\n"
69      | Wlexer.Unterminated_string ->
70          Format.fprintf ppf "String literal not terminated@\n"
71      | Wlexer.Unterminated_string_in_comment ->
72          Format.fprintf ppf "This comment contains an unterminated string literal@\n"
73      | Parser.Error s | Stream.Error s ->
74          Format.fprintf ppf "Parsing error: %s@\n" s
75      | Location.Generic s ->
76          Format.fprintf ppf "%s@\n" s
77    | exn ->    | exn ->
78        Format.fprintf ppf "%s@\n" (Printexc.to_string exn)        Format.fprintf ppf "%s@\n" (Printexc.to_string exn)
79    
80    let debug ppf = function
81      | `Filter (t,p) ->
82          Format.fprintf ppf "[DEBUG:filter]@\n";
83          let t = Typer.typ !glb_env t
84          and p = Typer.pat !glb_env p in
85          let f = Patterns.filter (Types.descr t) p in
86          List.iter (fun (x,t) ->
87                       Format.fprintf ppf " %s:%a@\n" x
88                         print_norm (Types.descr t)) f
89      | `Accept p ->
90          Format.fprintf ppf "[DEBUG:accept]@\n";
91          let p = Typer.pat !glb_env p in
92          let t = Patterns.accept p in
93          Format.fprintf ppf " %a@\n" Types.Print.print t
94      | `Compile (t,pl) ->
95          Format.fprintf ppf "[DEBUG:compile]@\n";
96          let t = Typer.typ !glb_env t
97          and pl = List.map (Typer.pat !glb_env) pl in
98          let pl = Array.of_list
99                     (List.map (fun p -> Patterns.Compile.normal
100                                  (Patterns.descr p)) pl) in
101          Patterns.Compile.show ppf (Types.descr t) pl
102      | `Normal_record t ->
103          Format.fprintf ppf "[DEBUG:normal_record]@\n";
104          let t = Types.descr (Typer.typ !glb_env t) in
105          let count = ref 0 and seen = ref [] in
106          match Types.Record.first_label t with
107                | `Empty -> Format.fprintf ppf "Empty"
108                | `Any -> Format.fprintf ppf "Any"
109                | `Label l ->
110                    let (pr,ab) = Types.Record.normal' t l in
111                    Format.fprintf ppf "Label (%s,@[" (Types.LabelPool.value l);
112                    List.iter (fun (d,n) ->
113                                 Format.fprintf ppf "%a => @[%a@];@\n"
114                                 Types.Print.print_descr d
115                                 Types.Print.print_descr n
116                              ) pr;
117                    Format.fprintf ppf "@] Absent: @[%a@])@\n"
118                      Types.Print.print_descr
119                      (match ab with Some x -> x | None -> Types.empty)
120    (*
121      | `Normal_record t ->
122          Format.fprintf ppf "[DEBUG:normal_record]@\n";
123          let t = Types.descr (Typer.typ !glb_env t) in
124          let r = Types.Record.normal t in
125          let count = ref 0 and seen = ref [] in
126          let rec aux ppf x =
127            try
128              let no = List.assq x !seen in
129              Format.fprintf ppf "[[%i]]" no
130            with Not_found ->
131              incr count;
132              seen := (x, !count) :: !seen;
133              Format.fprintf ppf "[[%i]]:" !count;
134              match x with
135                | `Success -> Format.fprintf ppf "Success"
136                | `Fail -> Format.fprintf ppf "Fail"
137                | `Label (l,pr,ab) ->
138                    Format.fprintf ppf "Label (%s,@[" (Types.label_name l);
139                    List.iter (fun (d,n) ->
140                                 Format.fprintf ppf "%a => @[%a@];@\n"
141                                 Types.Print.print_descr d
142                                 aux n
143                              ) pr;
144                    Format.fprintf ppf "@] Absent: @[%a@])" aux ab
145          in
146          Format.fprintf ppf "%a@\n" aux r
147    *)
148    
149    
150    
151    let mk_builtin () =
152      let bi = List.map (fun (n,t) -> [n, mk noloc (Ast.Internal t)])
153                 Builtin.types in
154      glb_env := List.fold_left Typer.register_global_types !glb_env bi
155    
156    let () = mk_builtin ()
157    
158    
159    let run ppf ppf_err input =
160      let insert_type_bindings =
161        List.iter (fun (x,t) ->
162                     typing_env := Typer.Env.add x t !typing_env;
163                     Format.fprintf ppf "|- %s : %a@\n@." x print_norm t)
164      in
165    
166      let type_decl decl =
167        insert_type_bindings (Typer.type_let_decl !typing_env decl)
168      in
169    
170      let eval_decl decl =
171        let bindings = Eval.eval_let_decl Eval.Env.empty decl in
172        List.iter
173          (fun (x,v) ->
174             Eval.enter_global x v;
175             Format.fprintf ppf "=> %s : @[%a@]@\n@." x print_value v
176          ) bindings
177      in
178    
179  let phrase ph =  let phrase ph =
180    match ph.descr with    match ph.descr with
181      | Ast.EvalStatement e ->      | Ast.EvalStatement e ->
182          let (fv,e) = Typer.expr e in            let (fv,e) = Typer.expr !glb_env e in
183          let t = Typer.type_check Typer.Env.empty e Types.any true in            let t = Typer.type_check !typing_env e Types.any true in
184          Format.fprintf ppf "%a@\n" Types.Print.print_descr t;            Location.dump_loc ppf e.Typed.exp_loc;
185              Format.fprintf ppf "|- %a@\n@." print_norm t;
186              let v = Eval.eval Eval.Env.empty e in
187              Format.fprintf ppf "=> @[%a@]@\n@." print_value v
188          | Ast.LetDecl (p,{descr=Ast.Abstraction _}) -> ()
189          | Ast.LetDecl (p,e) ->
190              let decl = Typer.let_decl !glb_env p e in
191              type_decl decl;
192              eval_decl decl
193      | Ast.TypeDecl _ -> ()      | Ast.TypeDecl _ -> ()
194          | Ast.Debug l -> debug ppf l
195      | _ -> assert false      | _ -> assert false
196      in
197    
198  let () =    let do_fun_decls decls =
199        let decls = List.map (fun (p,e) -> Typer.let_decl !glb_env p e) decls in
200        insert_type_bindings (Typer.type_rec_funs !typing_env decls);
201        List.iter eval_decl decls
202      in
203    try    try
204      let p = prog () in      let p =
205      let type_decls =        try Parser.prog input
206          with
207            | Stdpp.Exc_located (_, (Location _ as e)) -> raise e
208            | Stdpp.Exc_located (loc, e) -> raise (Location (loc, e))
209        in
210        let (type_decls,fun_decls) =
211        List.fold_left        List.fold_left
212          (fun accu ph -> match ph.descr with          (fun ((typs,funs) as accu) ph -> match ph.descr with
213             | Ast.TypeDecl (x,t) -> (x,t) :: accu             | Ast.TypeDecl (x,t) -> ((x,t) :: typs,funs)
214               | Ast.LetDecl (p,({descr=Ast.Abstraction _} as e)) ->
215                   (typs, (p,e)::funs)
216             | _ -> accu             | _ -> accu
217          ) [] p in          ) ([],[]) p in
218      Typer.register_global_types type_decls;      glb_env := Typer.register_global_types !glb_env type_decls;
219      List.iter phrase p      do_fun_decls fun_decls;
220    with (Failure _) as e -> raise e | exn -> print_exn ppf exn      List.iter phrase p;
221        true
222      with
223        | (Failure _ | Not_found | Invalid_argument _) as e ->
224            raise e  (* To get ocamlrun stack trace *)
225        | exn -> print_exn ppf_err exn; false
226    
227    
Legend:
Removed from v.19  
changed lines
  Added in v.124
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5