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

Diff of /driver/cduce.ml

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

revision 89 by abate, Tue Jul 10 17:04:39 2007 UTC revision 90 by abate, Tue Jul 10 17:05:20 2007 UTC
# Line 1  Line 1 
1  open Location  open Location
 exception Usage  
   
 let () =  
   List.iter  
     (fun (n,t) -> Typer.register_global_types [n, mk noloc (Ast.Internal t)])  
     Builtin.types  
   
   
 let (source,input_channel) =  
   match Array.length Sys.argv with  
     | 1 -> ("",stdin)  
     | 2 -> let s = Sys.argv.(1) in (s, open_in s)  
     | _ -> raise Usage  
   
 let () = Location.set_source source  
   
 let input = Stream.of_channel input_channel  
   
 let ppf = Format.std_formatter  
 let prog () =  
   try Parser.prog input  
   with  
     | Stdpp.Exc_located (_, (Location _ as e)) -> raise e  
     | Stdpp.Exc_located (loc, e) -> raise (Location (loc, e))  
2    
3  let print_norm ppf d =  let print_norm ppf d =
4    Types.Print.print_descr ppf ((*Types.normalize*) d)    Types.Print.print_descr ppf ((*Types.normalize*) d)
# Line 69  Line 45 
45        Format.fprintf ppf "String literal not terminated@\n"        Format.fprintf ppf "String literal not terminated@\n"
46    | Wlexer.Unterminated_string_in_comment ->    | Wlexer.Unterminated_string_in_comment ->
47        Format.fprintf ppf "This comment contains an unterminated string literal@\n"        Format.fprintf ppf "This comment contains an unterminated string literal@\n"
48    | Parser.Error s ->    | Parser.Error s | Stream.Error s ->
49        Format.fprintf ppf "Parsing error: %s@\n" s        Format.fprintf ppf "Parsing error: %s@\n" s
50    | exn ->    | exn ->
51        Format.fprintf ppf "%s@\n" (Printexc.to_string exn)        Format.fprintf ppf "%s@\n" (Printexc.to_string exn)
52    
53  let debug = function  let debug ppf = function
54    | `Filter (t,p) ->    | `Filter (t,p) ->
55        Format.fprintf ppf "[DEBUG:filter]@\n";        Format.fprintf ppf "[DEBUG:filter]@\n";
56        let t = Typer.typ t        let t = Typer.typ t
# Line 143  Line 119 
119        Format.fprintf ppf "%a@\n" aux r        Format.fprintf ppf "%a@\n" aux r
120  *)  *)
121    
122  let typing_env = ref Typer.Env.empty  
123  let eval_env = ref Eval.Env.empty  let mk_builtin () =
124      List.iter
125        (fun (n,t) -> Typer.register_global_types [n, mk noloc (Ast.Internal t)])
126        Builtin.types
127    
128    let run ppf input =
129      let typing_env = ref Typer.Env.empty in
130      let eval_env = ref Eval.Env.empty in
131    
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)                 Format.fprintf ppf "|- %s : %a@\n@." x print_norm t)
136      in
137    
138  let type_decl decl =  let type_decl decl =
139    insert_type_bindings (Typer.type_let_decl !typing_env decl)    insert_type_bindings (Typer.type_let_decl !typing_env decl)
140      in
141    
142  let eval_decl decl =  let eval_decl decl =
143    let bindings = Eval.eval_let_decl !eval_env decl in    let bindings = Eval.eval_let_decl !eval_env decl in
# Line 161  Line 146 
146         Eval.enter_global x v;         Eval.enter_global x v;
147         Format.fprintf ppf "=> %s : @[%a@]@\n@." x Value.print v         Format.fprintf ppf "=> %s : @[%a@]@\n@." x Value.print v
148      ) bindings      ) bindings
149      in
150    
151  let phrase ph =  let phrase ph =
152    match ph.descr with    match ph.descr with
# Line 176  Line 162 
162          type_decl decl;          type_decl decl;
163          eval_decl decl          eval_decl decl
164      | Ast.TypeDecl _ -> ()      | Ast.TypeDecl _ -> ()
165      | Ast.Debug l -> debug l        | Ast.Debug l -> debug ppf l
166      | _ -> assert false      | _ -> assert false
167      in
168    
169  let do_fun_decls decls =  let do_fun_decls decls =
170    let decls = List.map (fun (p,e) -> Typer.let_decl p e) decls in    let decls = List.map (fun (p,e) -> Typer.let_decl p e) decls in
171    insert_type_bindings (Typer.type_rec_funs !typing_env decls);    insert_type_bindings (Typer.type_rec_funs !typing_env decls);
172    List.iter eval_decl decls    List.iter eval_decl decls
173      in
   
 let () =  
174    try    try
175      let p = prog () in      mk_builtin ();
176        let p =
177          try Parser.prog input
178          with
179            | Stdpp.Exc_located (_, (Location _ as e)) -> raise e
180            | Stdpp.Exc_located (loc, e) -> raise (Location (loc, e))
181        in
182      let (type_decls,fun_decls) =      let (type_decls,fun_decls) =
183        List.fold_left        List.fold_left
184          (fun ((typs,funs) as accu) ph -> match ph.descr with          (fun ((typs,funs) as accu) ph -> match ph.descr with
# Line 201  Line 192 
192      List.iter phrase p      List.iter phrase p
193    with    with
194      | (Failure _ | Not_found | Invalid_argument _) as e ->      | (Failure _ | Not_found | Invalid_argument _) as e ->
195          raise e  (* To get the ocamlrun stack trace *)          raise e  (* To get ocamlrun stack trace *)
196      | exn -> print_exn ppf exn      | exn -> print_exn ppf exn
197    
198    
   
   
   
Legend:
Removed from v.89  
changed lines
  Added in v.90
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5