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

Diff of /driver/cduce.ml

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

revision 249 by abate, Tue Jul 10 17:19:14 2007 UTC revision 668 by abate, Tue Jul 10 17:52:43 2007 UTC
# Line 2  Line 2 
2  open Ident  open Ident
3    
4  let quiet = ref false  let quiet = ref false
5    let toplevel = ref false
6    
7  let typing_env = State.ref "Cduce.typing_env" Typer.Env.empty  let typing_env = State.ref "Cduce.typing_env" Env.empty
8  let glb_env = State.ref "Cduce.glb_env" Typer.TypeEnv.empty  
9  let eval_env = Eval.global_env  let eval_env = State.ref "Cduce.eval_env" Env.empty
10    
11    let enter_global_value x v t =
12      eval_env := Env.add x v !eval_env;
13      typing_env := Env.add x t !typing_env
14    
15    let rec is_abstraction = function
16      | Ast.Abstraction _ -> true
17      | Ast.LocatedExpr (_,e) -> is_abstraction e
18      | _ -> false
19    
20  let print_norm ppf d =  let print_norm ppf d =
21    Location.protect ppf    Location.protect ppf
22      (fun ppf -> Types.Print.print_descr ppf ((*Types.normalize*) d))      (fun ppf -> Types.Print.print ppf ((*Types.normalize*) d))
23    
24    let print_sample ppf s =
25      Location.protect ppf
26        (fun ppf -> Sample.print ppf s)
27    
28    let print_protect ppf s =
29      Location.protect ppf (fun ppf -> Format.fprintf ppf "%s" s)
30    
31  let print_value ppf v =  let print_value ppf v =
32    Location.protect ppf (fun ppf -> Value.print ppf v)    Location.protect ppf (fun ppf -> Value.print ppf v)
33    
34  let dump_env ppf =  let dump_env ppf =
35    Format.fprintf ppf "Global types:";    Format.fprintf ppf "Types:%t@." Typer.dump_global_types;
36    Typer.TypeEnv.iter (fun x _ -> Format.fprintf ppf " %s" x) !glb_env;    Format.fprintf ppf "Namespace prefixes:@\n%t" Typer.dump_global_ns;
37    Format.fprintf ppf ".@\n";    Format.fprintf ppf "Namespace prefixes used for pretty-printing:@.%t"
38    Eval.Env.iter      Ns.InternalPrinter.dump;
39      Format.fprintf ppf "Values:@\n";
40      Env.iter
41      (fun x v ->      (fun x v ->
42         let t = Typer.Env.find x !typing_env in         let t = Env.find x !typing_env in
43         Format.fprintf ppf "@[|- %s : %a@ => %a@]@\n"         Format.fprintf ppf "@[val %a : @[%a = %a@]@]@."
44           (Id.value x)           U.print (Id.value x) print_norm t print_value v
          print_norm t  
          print_value v  
45      )      )
46      !eval_env      !eval_env
47    
   
48  let rec print_exn ppf = function  let rec print_exn ppf = function
49    | Location (loc, exn) ->    | Location (loc, w, exn) ->
50        Format.fprintf ppf "Error %a:@\n" Location.print_loc loc;        Format.fprintf ppf "Error %a:@." Location.print_loc (loc,w);
51        Format.fprintf ppf "%a" Location.html_hilight loc;        Format.fprintf ppf "%a" Location.html_hilight (loc,w);
52        print_exn ppf exn        print_exn ppf exn
53    | Value.CDuceExn v ->    | Value.CDuceExn v ->
54        Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@\n"        Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@."
55          print_value v          print_value v
56      | Eval.MultipleDeclaration v ->
57          Format.fprintf ppf "Multiple declaration for global value %a@."
58            U.print (Id.value v)
59    | Typer.WrongLabel (t,l) ->    | Typer.WrongLabel (t,l) ->
60        Format.fprintf ppf "Wrong record selection: the label %s@\n"        Format.fprintf ppf "Wrong record selection; field %a "
61          (LabelPool.value l);          Label.print (LabelPool.value l);
62        Format.fprintf ppf "applied to an expression of type %a@\n"        Format.fprintf ppf "not present in an expression of type:@.%a@."
63          print_norm t          print_norm t
64    | Typer.ShouldHave (t,msg) ->    | Typer.ShouldHave (t,msg) ->
65        Format.fprintf ppf "This expression should have type %a@\n%s@\n"        Format.fprintf ppf "This expression should have type:@.%a@.%a@."
66          print_norm t          print_norm t
67          msg          print_protect msg
68    | Typer.Constraint (s,t,msg) ->    | Typer.ShouldHave2 (t1,msg,t2) ->
69        Format.fprintf ppf "This expression should have type %a@\n"        Format.fprintf ppf "This expression should have type:@.%a@.%a %a@."
70            print_norm t1
71            print_protect msg
72            print_norm t2
73      | Typer.Error s ->
74          Format.fprintf ppf "%a@." print_protect s
75      | Typer.Constraint (s,t) ->
76          Format.fprintf ppf "This expression should have type:@.%a@."
77          print_norm t;          print_norm t;
78        Format.fprintf ppf "but its infered type is: %a@\n"        Format.fprintf ppf "but its inferred type is:@.%a@."
79          print_norm s;          print_norm s;
80        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 sample:@.%a@."
81          Types.Sample.print (Types.Sample.get (Types.diff s t));          print_sample (Sample.get (Types.diff s t))
       Format.fprintf ppf "%s@\n" msg  
82    | Typer.NonExhaustive t ->    | Typer.NonExhaustive t ->
83        Format.fprintf ppf "This pattern matching is not exhaustive@\n";        Format.fprintf ppf "This pattern matching is not exhaustive@.";
84        Format.fprintf ppf "Residual type: %a@\n"        Format.fprintf ppf "Residual type:@.%a@."
85          print_norm t;          print_norm t;
86        Format.fprintf ppf "Sample value: %a@\n"        Format.fprintf ppf "Sample:@.%a@." print_sample (Sample.get t)
87          Types.Sample.print (Types.Sample.get t)    | Typer.UnboundId (x,tn) ->
88    | Typer.UnboundId x ->        Format.fprintf ppf "Unbound identifier %a%s@." U.print (Id.value x)
89        Format.fprintf ppf "Unbound identifier %s@\n" x          (if tn then " (it is a type name)" else "")
90    | Wlexer.Illegal_character c ->    | Ulexer.Error (i,j,s) ->
91        Format.fprintf ppf "Illegal character (%s)@\n" (Char.escaped c)        let loc = Location.loc_of_pos (i,j), `Full in
92    | Wlexer.Unterminated_comment ->        Format.fprintf ppf "Error %a:@." Location.print_loc loc;
93        Format.fprintf ppf "Comment not terminated@\n"        Format.fprintf ppf "%a%s" Location.html_hilight loc s
   | Wlexer.Unterminated_string ->  
       Format.fprintf ppf "String literal not terminated@\n"  
   | Wlexer.Unterminated_string_in_comment ->  
       Format.fprintf ppf "This comment contains an unterminated string literal@\n"  
94    | Parser.Error s | Stream.Error s ->    | Parser.Error s | Stream.Error s ->
95        Format.fprintf ppf "Parsing error: %s@\n" s        Format.fprintf ppf "Parsing error: %a@." print_protect s
96    | Location.Generic s ->    | Location.Generic s ->
97        Format.fprintf ppf "%s@\n" s        Format.fprintf ppf "%a@." print_protect s
98    | exn ->    | exn ->
99        raise exn  (*      raise exn *)
100  (*        Format.fprintf ppf "%a@." print_protect (Printexc.to_string exn)
       Format.fprintf ppf "%s@\n" (Printexc.to_string exn)  
 *)  
101    
102  let debug ppf = function  let debug ppf = function
103    | `Subtype (t1,t2) ->    | `Subtype (t1,t2) ->
104        Format.fprintf ppf "[DEBUG:subtype]@\n";        Format.fprintf ppf "[DEBUG:subtype]@.";
105        let t1 = Types.descr (Typer.typ !glb_env t1)        let t1 = Types.descr (Typer.typ t1)
106        and t2 = Types.descr (Typer.typ !glb_env t2) in        and t2 = Types.descr (Typer.typ t2) in
107        Format.fprintf ppf "%a <= %a : %b@\n" print_norm t1 print_norm t2        let s = Types.subtype t1 t2 in
108          (Types.subtype t1 t2)        Format.fprintf ppf "%a %a %a : %b@." print_norm t1 print_protect "<=" print_norm t2 s
109      | `Sample t ->
110          Format.fprintf ppf "[DEBUG:sample]@.";
111          (try
112             let t = Types.descr (Typer.typ t) in
113             Format.fprintf ppf "%a@." print_sample (Sample.get t)
114           with Not_found ->
115             Format.fprintf ppf "Empty type : no sample !@.")
116    | `Filter (t,p) ->    | `Filter (t,p) ->
117        Format.fprintf ppf "[DEBUG:filter]@\n";        Format.fprintf ppf "[DEBUG:filter]@.";
118        let t = Typer.typ !glb_env t        let t = Typer.typ t
119        and p = Typer.pat !glb_env p in        and p = Typer.pat p in
120        let f = Patterns.filter (Types.descr t) p in        let f = Patterns.filter (Types.descr t) p in
121        List.iter (fun (x,t) ->        List.iter (fun (x,t) ->
122                     Format.fprintf ppf " %s:%a@\n" (Id.value x)                     Format.fprintf ppf " %a:%a@." U.print (Id.value x)
123                       print_norm (Types.descr t)) f                       print_norm (Types.descr t)) f
   | `Compile2 (t,pl) ->  
       Format.fprintf ppf "[DEBUG:compile2]@\n";  
 (*      let t = Types.descr (Typer.typ !glb_env t) in  
       let pl = List.map (fun p ->  
                            let p = Typer.pat !glb_env p in  
                            let a = Types.descr (Patterns.accept p) in  
                            (Some p, Types.cap a t)) pl in  
       let d = Patterns.Compiler.make_dispatcher t pl in  
       Patterns.Compiler.print_disp ppf d *)  
       ()  
   
124    | `Accept p ->    | `Accept p ->
125        Format.fprintf ppf "[DEBUG:accept]@\n";        Format.fprintf ppf "[DEBUG:accept]@.";
126        let p = Typer.pat !glb_env p in        let p = Typer.pat p in
127        let t = Patterns.accept p in        let t = Patterns.accept p in
128        Format.fprintf ppf " %a@\n" Types.Print.print t        Format.fprintf ppf " %a@." Types.Print.print (Types.descr t)
129    | `Compile (t,pl) ->    | `Compile (t,pl) ->
130        Format.fprintf ppf "[DEBUG:compile]@\n";        Format.fprintf ppf "[DEBUG:compile]@.";
131        let t = Typer.typ !glb_env t        let t = Typer.typ t
132        and pl = List.map (Typer.pat !glb_env) pl in        and pl = List.map Typer.pat pl in
133        Patterns.Compile.debug_compile ppf t pl        Patterns.Compile.debug_compile ppf t pl
   | `Normal_record p -> assert false  
   
   
   
 let mk_builtin () =  
   let bi = List.map (fun (n,t) -> [n, mknoloc (Ast.Internal t)])  
              Builtin.types in  
   glb_env := List.fold_left Typer.register_global_types !glb_env bi  
   
 let () = mk_builtin ()  
134    
135    let insert_bindings ppf =
136  let run ppf ppf_err input =    List.iter2
137    let insert_type_bindings =      (fun (x,t) (y,v) ->
138      List.iter (fun (x,t) ->         assert (x = y);
139                   typing_env := Typer.Env.add x t !typing_env;         typing_env := Env.add x t !typing_env;
140           eval_env := Env.add x v !eval_env;
141                   if not !quiet then                   if not !quiet then
142                     Format.fprintf ppf "|- %s : %a@\n@." (Id.value x) print_norm t)           Format.fprintf ppf "val %a : @[@[%a@] =@ @[%a@]@]@."
143    in             U.print (Id.value x) print_norm t print_value v)
144    
145    let type_decl decl =  let rec collect_funs ppf accu = function
146      insert_type_bindings (Typer.type_let_decl !typing_env decl)    | { descr = Ast.FunDecl e } :: rest ->
147    in        let (_,e) = Typer.expr e in
148          collect_funs ppf (e::accu) rest
149    let eval_decl decl =    | rest ->
150      let bindings = Eval.eval_let_decl Eval.Env.empty decl in        let typs = Typer.type_rec_funs !typing_env accu in
151      List.iter        Typer.report_unused_branches ();
152        (fun (x,v) ->        let vals = Eval.eval_rec_funs !eval_env accu in
153           Eval.enter_global x v;        insert_bindings ppf typs vals;
154           if not !quiet then        rest
155             Format.fprintf ppf "=> %s : @[%a@]@\n@." (Id.value x) print_value v  
156        ) bindings  let rec collect_types ppf accu = function
157    in    | { descr = Ast.TypeDecl (x,t) } :: rest ->
158          collect_types ppf ((x,t) :: accu) rest
159    let phrase ph =    | rest ->
160      match ph.descr with        Typer.register_global_types accu;
161        | Ast.EvalStatement e ->        rest
162            let (fv,e) = Typer.expr !glb_env e in  
163    let rec phrases ppf phs = match phs with
164      | { descr = Ast.FunDecl _ } :: _ ->
165          phrases ppf (collect_funs ppf [] phs)
166      | { descr = Ast.TypeDecl (_,_) } :: _ ->
167          phrases ppf (collect_types ppf [] phs)
168      | { descr = Ast.SchemaDecl (name, schema) } :: rest ->
169          Typer.register_schema name schema;
170          phrases ppf rest
171      | { descr = Ast.Namespace (pr,ns) } :: rest ->
172          Typer.register_global_ns pr ns;
173          phrases ppf rest
174      | { descr = Ast.EvalStatement e } :: rest ->
175          let (fv,e) = Typer.expr e in
176            let t = Typer.type_check !typing_env e Types.any true in            let t = Typer.type_check !typing_env e Types.any true in
177            Location.dump_loc ppf e.Typed.exp_loc;        Typer.report_unused_branches ();
178            if not !quiet then            if not !quiet then
179              Format.fprintf ppf "|- %a@\n@." print_norm t;          Location.dump_loc ppf (e.Typed.exp_loc,`Full);
180            let v = Eval.eval Eval.Env.empty e in        let v = Eval.eval !eval_env e in
181            if not !quiet then            if not !quiet then
182              Format.fprintf ppf "=> @[%a@]@\n@." print_value v          Format.fprintf ppf "- : @[@[%a@] =@ @[%a@]@]@." print_norm t print_value v;
183        | Ast.LetDecl (p,{descr=Ast.Abstraction _}) -> ()        phrases ppf rest
184        | Ast.LetDecl (p,e) ->    | { descr = Ast.LetDecl (p,e) } :: rest ->
185            let decl = Typer.let_decl !glb_env p e in        let decl = Typer.let_decl p e in
186            type_decl decl;        let typs = Typer.type_let_decl !typing_env decl in
187            eval_decl decl        Typer.report_unused_branches ();
188        | Ast.TypeDecl _ -> ()        let vals = Eval.eval_let_decl !eval_env decl in
189        | Ast.Debug l -> debug ppf l        insert_bindings ppf typs vals;
190        | _ -> assert false        phrases ppf rest
191    in    | { descr = Ast.Debug l } :: rest ->
192          debug ppf l;
193          phrases ppf rest
194      | { descr = Ast.Directive `Quit } :: rest ->
195          if !toplevel then raise End_of_file;
196          phrases ppf rest
197      | { descr = Ast.Directive `Env } :: rest ->
198          dump_env ppf;
199          phrases ppf rest
200      | { descr = Ast.Directive `Reinit_ns } :: rest ->
201          Typer.set_ns_table_for_printer ();
202          phrases ppf rest
203      | [] -> ()
204    
205    let do_fun_decls decls =  let run rule ppf ppf_err input =
206      let decls = List.map (fun (p,e) -> Typer.let_decl !glb_env p e) decls in    Typer.clear_unused_branches ();
     insert_type_bindings (Typer.type_rec_funs !typing_env decls);  
     List.iter eval_decl decls  
   in  
   let rec phrases funs = function  
     | { descr = Ast.LetDecl (p,({descr=Ast.Abstraction _} as e))} :: phs ->  
         phrases ((p,e)::funs) phs  
     | ph :: phs ->  
         do_fun_decls funs;  
         phrase ph;  
         phrases [] phs  
     | _ ->  
         do_fun_decls funs  
   in  
207    try    try
208      let p =      let p =
209        try Parser.prog input        try rule input
210        with        with
211          | Stdpp.Exc_located (_, (Location _ as e)) -> raise e          | Stdpp.Exc_located (_, (Location _ as e)) ->
212          | Stdpp.Exc_located ((i,j), e) -> raise_loc i j e              Parser.sync (); raise e
213            | Stdpp.Exc_located ((i,j), e) ->
214                Parser.sync (); raise_loc i j e
215      in      in
216      let (type_decls,fun_decls) =      phrases ppf p;
       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  
     glb_env := Typer.register_global_types !glb_env type_decls;  
     phrases [] p;  
217      true      true
218    with    with
219      | (Failure _ | Not_found | Invalid_argument _) as e ->      | (End_of_file | Failure _ | Not_found | Invalid_argument _ | Sys.Break)
220          raise e  (* To get ocamlrun stack trace *)          as e ->
221      | exn -> print_exn ppf_err exn; false          raise e
222        | exn ->
223            print_exn ppf_err exn;
224            Format.fprintf ppf_err "@.";
225            false
226    
227    let script = run Parser.prog
228    let topinput = run Parser.top_phrases
Legend:
Removed from v.249  
changed lines
  Added in v.668
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5