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

Diff of /driver/cduce.ml

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

revision 136 by abate, Tue Jul 10 17:09:36 2007 UTC revision 249 by abate, Tue Jul 10 17:19:14 2007 UTC
# Line 1  Line 1 
1  open Location  open Location
2    open Ident
3    
4    let quiet = ref false
5    
6  let typing_env = State.ref "Cduce.typing_env" Typer.Env.empty  let typing_env = State.ref "Cduce.typing_env" Typer.Env.empty
7  let glb_env = State.ref "Cduce.glb_env" Typer.Env.empty  let glb_env = State.ref "Cduce.glb_env" Typer.TypeEnv.empty
8  let eval_env = Eval.global_env  let eval_env = Eval.global_env
9    
10  let print_norm ppf d =  let print_norm ppf d =
# Line 13  Line 16 
16    
17  let dump_env ppf =  let dump_env ppf =
18    Format.fprintf ppf "Global types:";    Format.fprintf ppf "Global types:";
19    Typer.Env.iter (fun x _ -> Format.fprintf ppf " %s" x) !glb_env;    Typer.TypeEnv.iter (fun x _ -> Format.fprintf ppf " %s" x) !glb_env;
20    Format.fprintf ppf ".@\n";    Format.fprintf ppf ".@\n";
21    Eval.Env.iter    Eval.Env.iter
22      (fun x v ->      (fun x v ->
23         let t = Typer.Env.find x !typing_env in         let t = Typer.Env.find x !typing_env in
24         Format.fprintf ppf "@[|- %s : %a@ => %a@]@\n"         Format.fprintf ppf "@[|- %s : %a@ => %a@]@\n"
25           x           (Id.value x)
26           print_norm t           print_norm t
27           print_value v           print_value v
28      )      )
# Line 36  Line 39 
39          print_value v          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.LabelPool.value 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.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          print_norm t          print_norm t
# Line 81  Line 81 
81  *)  *)
82    
83  let debug ppf = 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 !glb_env t        let t = Typer.typ !glb_env t
93        and p = Typer.pat !glb_env 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 " %s:%a@\n" x                     Format.fprintf ppf " %s:%a@\n" (Id.value x)
97                       print_norm (Types.descr t)) f                       print_norm (Types.descr t)) f
98    | `Restrict (p,t) ->    | `Compile2 (t,pl) ->
99        Format.fprintf ppf "[DEBUG:restrict]@\n";        Format.fprintf ppf "[DEBUG:compile2]@\n";
100        let t = Typer.typ !glb_env t  (*      let t = Types.descr (Typer.typ !glb_env t) in
101        and p = Typer.pat !glb_env p in        let pl = List.map (fun p ->
102  (*      let f = Patterns.restrict (Patterns.descr p) (Types.descr t) in                             let p = Typer.pat !glb_env p in
103        (match f with                             let a = Types.descr (Patterns.accept p) in
104          | `Pat q -> Format.fprintf ppf "Pat: %a@\n" Patterns.print q                             (Some p, Types.cap a t)) pl in
105          | `Accept -> Format.fprintf ppf "Accept@\n"        let d = Patterns.Compiler.make_dispatcher t pl in
106          | `Reject -> Format.fprintf ppf "Reject@\n") *)        Patterns.Compiler.print_disp ppf d *)
107        Patterns.demo ppf (Patterns.descr p) (Types.descr t)        ()
108    
109    | `Accept p ->    | `Accept p ->
110        Format.fprintf ppf "[DEBUG:accept]@\n";        Format.fprintf ppf "[DEBUG:accept]@\n";
111        let p = Typer.pat !glb_env p in        let p = Typer.pat !glb_env p in
# Line 108  Line 115 
115        Format.fprintf ppf "[DEBUG:compile]@\n";        Format.fprintf ppf "[DEBUG:compile]@\n";
116        let t = Typer.typ !glb_env t        let t = Typer.typ !glb_env t
117        and pl = List.map (Typer.pat !glb_env) 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
                               (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 !glb_env 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.LabelPool.value 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 !glb_env 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  
 *)  
120    
121    
122    
# Line 173  Line 132 
132    let insert_type_bindings =    let insert_type_bindings =
133      List.iter (fun (x,t) ->      List.iter (fun (x,t) ->
134                   typing_env := Typer.Env.add x t !typing_env;                   typing_env := Typer.Env.add x t !typing_env;
135                   Format.fprintf ppf "|- %s : %a@\n@." x print_norm t)                   if not !quiet then
136                       Format.fprintf ppf "|- %s : %a@\n@." (Id.value x) print_norm t)
137    in    in
138    
139    let type_decl decl =    let type_decl decl =
# Line 185  Line 145 
145      List.iter      List.iter
146        (fun (x,v) ->        (fun (x,v) ->
147           Eval.enter_global x v;           Eval.enter_global x v;
148           Format.fprintf ppf "=> %s : @[%a@]@\n@." x print_value v           if not !quiet then
149               Format.fprintf ppf "=> %s : @[%a@]@\n@." (Id.value x) print_value v
150        ) bindings        ) bindings
151    in    in
152    
# Line 195  Line 156 
156            let (fv,e) = Typer.expr !glb_env e in            let (fv,e) = Typer.expr !glb_env e in
157            let t = Typer.type_check !typing_env e Types.any true in            let t = Typer.type_check !typing_env e Types.any true in
158            Location.dump_loc ppf e.Typed.exp_loc;            Location.dump_loc ppf e.Typed.exp_loc;
159              if not !quiet then
160            Format.fprintf ppf "|- %a@\n@." print_norm t;            Format.fprintf ppf "|- %a@\n@." print_norm t;
161            let v = Eval.eval Eval.Env.empty e in            let v = Eval.eval Eval.Env.empty e in
162              if not !quiet then
163            Format.fprintf ppf "=> @[%a@]@\n@." print_value v            Format.fprintf ppf "=> @[%a@]@\n@." print_value v
164        | Ast.LetDecl (p,{descr=Ast.Abstraction _}) -> ()        | Ast.LetDecl (p,{descr=Ast.Abstraction _}) -> ()
165        | Ast.LetDecl (p,e) ->        | Ast.LetDecl (p,e) ->
# Line 228  Line 191 
191        try Parser.prog input        try Parser.prog input
192        with        with
193          | Stdpp.Exc_located (_, (Location _ as e)) -> raise e          | Stdpp.Exc_located (_, (Location _ as e)) -> raise e
194          | Stdpp.Exc_located (loc, e) -> raise (Location (loc, e))          | Stdpp.Exc_located ((i,j), e) -> raise_loc i j e
195      in      in
196      let (type_decls,fun_decls) =      let (type_decls,fun_decls) =
197        List.fold_left        List.fold_left
Legend:
Removed from v.136  
changed lines
  Added in v.249
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5