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

Diff of /driver/cduce.ml

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

revision 43 by abate, Tue Jul 10 17:00:25 2007 UTC revision 233 by abate, Tue Jul 10 17:17:31 2007 UTC
# Line 1  Line 1 
1  open Location  open Location
2  exception Usage  open Ident
3    
4  let () =  let quiet = ref false
   List.iter  
     (fun (n,t) -> Typer.register_global_types [n, mk noloc (Ast.Internal t)])  
     Builtin.types  
5    
6    let typing_env = State.ref "Cduce.typing_env" Typer.Env.empty
7    let glb_env = State.ref "Cduce.glb_env" Typer.TypeEnv.empty
8    let eval_env = Eval.global_env
9    
10  let (source,input_channel) =  let print_norm ppf d =
11    match Array.length Sys.argv with    Location.protect ppf
12      | 1 -> ("",stdin)      (fun ppf -> Types.Print.print_descr ppf ((*Types.normalize*) d))
     | 2 -> let s = Sys.argv.(1) in (s, open_in s)  
     | _ -> raise Usage  
13    
14  let input = Stream.of_channel input_channel  let print_value ppf v =
15      Location.protect ppf (fun ppf -> Value.print ppf v)
16    
17  let ppf = Format.std_formatter  let dump_env ppf =
18  let prog () =    Format.fprintf ppf "Global types:";
19    try Parser.prog input    Typer.TypeEnv.iter (fun x _ -> Format.fprintf ppf " %s" x) !glb_env;
20    with    Format.fprintf ppf ".@\n";
21      | Stdpp.Exc_located (loc, e) -> raise (Location (loc, e))    Eval.Env.iter
22        (fun x v ->
23           let t = Typer.Env.find x !typing_env in
24           Format.fprintf ppf "@[|- %s : %a@ => %a@]@\n"
25             (Id.value x)
26             print_norm t
27             print_value v
28        )
29        !eval_env
30    
 let print_norm ppf d =  
   Types.Print.print_descr ppf (Types.normalize d)  
31    
32  let rec print_exn ppf = function  let rec print_exn ppf = function
33    | Location ((i,j), exn) ->    | Location (loc, exn) ->
34        if source = "" then        Format.fprintf ppf "Error %a:@\n" Location.print_loc loc;
35          Format.fprintf ppf "Error at chars %i-%i@\n" i j        Format.fprintf ppf "%a" Location.html_hilight loc;
       else (  
         let (l1,c1) = Location.get_line_number source i  
         and (l2,c2) = Location.get_line_number source j in  
         if l1 = l2 then  
           Format.fprintf ppf "Error at line %i (chars %i-%i)@\n"  
             l1 c1 c2  
         else  
           Format.fprintf ppf "Error at lines %i (char %i) - %i (char %i)@\n"  
             l1 c1 l2 c2  
       );  
36        print_exn ppf exn        print_exn ppf exn
37      | Value.CDuceExn v ->
38          Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@\n"
39            print_value v
40    | Typer.WrongLabel (t,l) ->    | Typer.WrongLabel (t,l) ->
41        Format.fprintf ppf "Wrong record selection: the label %s@\n"        Format.fprintf ppf "Wrong record selection: the label %s@\n"
42          (Types.label_name l);          (LabelPool.value l);
43        Format.fprintf ppf "applied to an expression of type %a@\n"        Format.fprintf ppf "applied to an expression of type %a@\n"
44          print_norm t          print_norm t
   | Typer.MultipleLabel l ->  
       Format.fprintf ppf "Multiple occurences for the record label %s@\n"  
         (Types.label_name 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          print_norm t          print_norm t
# Line 57  Line 52 
52        Format.fprintf ppf "but its infered type is: %a@\n"        Format.fprintf ppf "but its infered type is: %a@\n"
53          print_norm 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          print_norm 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 ->    | Typer.UnboundId x ->
64        Format.fprintf ppf "Unbound identifier %s@\n" x        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          raise exn
79    (*
80        Format.fprintf ppf "%s@\n" (Printexc.to_string exn)        Format.fprintf ppf "%s@\n" (Printexc.to_string exn)
81    *)
82    
83  let debug = function  let debug ppf = function
84      | `Subtype (t1,t2) ->
85          Format.fprintf ppf "[DEBUG:subtype]@\n";
86          let t1 = Types.descr (Typer.typ !glb_env t1)
87          and t2 = Types.descr (Typer.typ !glb_env t2) in
88          Format.fprintf ppf "%a <= %a : %b@\n" print_norm t1 print_norm t2
89            (Types.subtype t1 t2)
90    | `Filter (t,p) ->    | `Filter (t,p) ->
91        Format.fprintf ppf "[DEBUG:filter]@\n";        Format.fprintf ppf "[DEBUG:filter]@\n";
92        let t = Typer.typ t        let t = Typer.typ !glb_env t
93        and p = Typer.pat p in        and p = Typer.pat !glb_env p in
94        let f = Patterns.filter (Types.descr t) p in        let f = Patterns.filter (Types.descr t) p in
95        List.iter (fun (x,t) ->        List.iter (fun (x,t) ->
96                     Format.fprintf ppf " x:%a@\n"                     Format.fprintf ppf " %s:%a@\n" (Id.value x)
97                       print_norm (Types.descr t)) f                       print_norm (Types.descr t)) f
98      | `Compile2 (t,pl) ->
99          Format.fprintf ppf "[DEBUG:compile2]@\n";
100    (*      let t = Types.descr (Typer.typ !glb_env t) in
101          let pl = List.map (fun p ->
102                               let p = Typer.pat !glb_env p in
103                               let a = Types.descr (Patterns.accept p) in
104                               (Some p, Types.cap a t)) pl in
105          let d = Patterns.Compiler.make_dispatcher t pl in
106          Patterns.Compiler.print_disp ppf d *)
107          ()
108    
109    | `Accept p ->    | `Accept p ->
110        Format.fprintf ppf "[DEBUG:accept]@\n";        Format.fprintf ppf "[DEBUG:accept]@\n";
111        let p = Typer.pat p in        let p = Typer.pat !glb_env p in
112        let t = Patterns.accept p in        let t = Patterns.accept p in
113        Format.fprintf ppf " %a@\n" Types.Print.print t        Format.fprintf ppf " %a@\n" Types.Print.print t
114    | `Compile (t,pl) ->    | `Compile (t,pl) ->
115        Format.fprintf ppf "[DEBUG:compile]@\n";        Format.fprintf ppf "[DEBUG:compile]@\n";
116        let t = Typer.typ t        let t = Typer.typ !glb_env t
117        and pl = List.map Typer.pat pl in        and pl = List.map (Typer.pat !glb_env) pl in
118        let pl = Array.of_list        Patterns.Compile.debug_compile ppf t pl
119                   (List.map (fun p -> Patterns.Compile.normal    | `Normal_record p -> assert false
120                                (Patterns.descr p)) pl) in  
121        Patterns.Compile.show ppf (Types.descr t) pl  
122    | _ -> Format.fprintf ppf "Unknown or ill-formed debugging directive !! @\n"  
123    let mk_builtin () =
124      let bi = List.map (fun (n,t) -> [n, mk noloc (Ast.Internal t)])
125                 Builtin.types in
126      glb_env := List.fold_left Typer.register_global_types !glb_env bi
127    
128    let () = mk_builtin ()
129    
130    
131    let run ppf ppf_err input =
132      let insert_type_bindings =
133        List.iter (fun (x,t) ->
134                     typing_env := Typer.Env.add x t !typing_env;
135                     if not !quiet then
136                       Format.fprintf ppf "|- %s : %a@\n@." (Id.value x) print_norm t)
137      in
138    
139      let type_decl decl =
140        insert_type_bindings (Typer.type_let_decl !typing_env decl)
141      in
142    
143      let eval_decl decl =
144        let bindings = Eval.eval_let_decl Eval.Env.empty decl in
145        List.iter
146          (fun (x,v) ->
147             Eval.enter_global x v;
148             if not !quiet then
149               Format.fprintf ppf "=> %s : @[%a@]@\n@." (Id.value x) print_value v
150          ) bindings
151      in
152    
153  let phrase ph =  let phrase ph =
154    match ph.descr with    match ph.descr with
155      | Ast.EvalStatement e ->      | Ast.EvalStatement e ->
156          let (fv,e) = Typer.expr e in            let (fv,e) = Typer.expr !glb_env e in
157          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
158          Format.fprintf ppf "%a@\n" print_norm t            Location.dump_loc ppf e.Typed.exp_loc;
159              if not !quiet then
160                Format.fprintf ppf "|- %a@\n@." print_norm t;
161              let v = Eval.eval Eval.Env.empty e in
162              if not !quiet then
163                Format.fprintf ppf "=> @[%a@]@\n@." print_value v
164          | Ast.LetDecl (p,{descr=Ast.Abstraction _}) -> ()
165          | Ast.LetDecl (p,e) ->
166              let decl = Typer.let_decl !glb_env p e in
167              type_decl decl;
168              eval_decl decl
169      | Ast.TypeDecl _ -> ()      | Ast.TypeDecl _ -> ()
170      | Ast.Debug l -> debug l        | Ast.Debug l -> debug ppf l
171      | _ -> assert false      | _ -> assert false
172      in
173    
174  let () =    let do_fun_decls decls =
175        let decls = List.map (fun (p,e) -> Typer.let_decl !glb_env p e) decls in
176        insert_type_bindings (Typer.type_rec_funs !typing_env decls);
177        List.iter eval_decl decls
178      in
179      let rec phrases funs = function
180        | { descr = Ast.LetDecl (p,({descr=Ast.Abstraction _} as e))} :: phs ->
181            phrases ((p,e)::funs) phs
182        | ph :: phs ->
183            do_fun_decls funs;
184            phrase ph;
185            phrases [] phs
186        | _ ->
187            do_fun_decls funs
188      in
189    try    try
190      let p = prog () in      let p =
191      let type_decls =        try Parser.prog input
192          with
193            | Stdpp.Exc_located (_, (Location _ as e)) -> raise e
194            | Stdpp.Exc_located (loc, e) -> raise (Location (loc, e))
195        in
196        let (type_decls,fun_decls) =
197        List.fold_left        List.fold_left
198          (fun accu ph -> match ph.descr with          (fun ((typs,funs) as accu) ph -> match ph.descr with
199             | Ast.TypeDecl (x,t) -> (x,t) :: accu             | Ast.TypeDecl (x,t) -> ((x,t) :: typs,funs)
200               | Ast.LetDecl (p,({descr=Ast.Abstraction _} as e)) ->
201                   (typs, (p,e)::funs)
202             | _ -> accu             | _ -> accu
203          ) [] p in          ) ([],[]) p in
204      Typer.register_global_types type_decls;      glb_env := Typer.register_global_types !glb_env type_decls;
205      List.iter phrase p      phrases [] p;
206        true
207    with    with
208      | (Failure _ | Not_found) as e ->      | (Failure _ | Not_found | Invalid_argument _) as e ->
209          raise e  (* To get the ocamlrun stack trace *)          raise e  (* To get ocamlrun stack trace *)
210      | exn -> print_exn ppf exn      | exn -> print_exn ppf_err exn; false
   
   
   
211    
212    
Legend:
Removed from v.43  
changed lines
  Added in v.233
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5