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

Diff of /driver/cduce.ml

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

revision 65 by abate, Tue Jul 10 17:02:32 2007 UTC revision 66 by abate, Tue Jul 10 17:02:51 2007 UTC
# Line 13  Line 13 
13      | 2 -> let s = Sys.argv.(1) in (s, open_in s)      | 2 -> let s = Sys.argv.(1) in (s, open_in s)
14      | _ -> raise Usage      | _ -> raise Usage
15    
16    let () = Location.set_source source
17    
18  let input = Stream.of_channel input_channel  let input = Stream.of_channel input_channel
19    
20  let ppf = Format.std_formatter  let ppf = Format.std_formatter
# Line 25  Line 27 
27    Types.Print.print_descr ppf (Types.normalize d)    Types.Print.print_descr ppf (Types.normalize d)
28    
29  let rec print_exn ppf = function  let rec print_exn ppf = function
30    | Location ((i,j), exn) ->    | Location (loc, exn) ->
31        if source = "" then        Format.fprintf ppf "Error %a:@\n%a" Location.print_loc loc print_exn exn
         Format.fprintf ppf "Error at chars %i-%i@\n" i j  
       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  
       );  
       print_exn ppf exn  
32    | Value.CDuceExn v ->    | Value.CDuceExn v ->
33        Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@\n"        Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@\n"
34          Value.print v          Value.print v
# Line 96  Line 86 
86                                (Patterns.descr p)) pl) in                                (Patterns.descr p)) pl) in
87        Patterns.Compile.show ppf (Types.descr t) pl        Patterns.Compile.show ppf (Types.descr t) pl
88    | _ -> Format.fprintf ppf "Unknown or ill-formed debugging directive !! @\n"    | _ -> Format.fprintf ppf "Unknown or ill-formed debugging directive !! @\n"
89    
90    let typing_env = ref Typer.Env.empty
91    let eval_env = ref Value.Env.empty
92    
93    let insert_type_bindings =
94      List.iter (fun (x,t) ->
95                   typing_env := Typer.Env.add x t !typing_env;
96                   Format.fprintf ppf "|- %s : %a@\n" x print_norm t)
97    
98    let type_decl decl =
99      insert_type_bindings (Typer.type_let_decl !typing_env decl)
100    
101    let eval_decl decl =
102      let bindings = Value.eval_let_decl !eval_env decl in
103      List.iter
104        (fun (x,v) ->
105           eval_env := Value.Env.add x v !eval_env;
106           Format.fprintf ppf "=> %s : @[%a@]@\n" x Value.print v
107        ) bindings
108    
109  let phrase ph =  let phrase ph =
110    match ph.descr with    match ph.descr with
111      | Ast.EvalStatement e ->      | Ast.EvalStatement e ->
112          let (fv,e) = Typer.expr e in          let (fv,e) = Typer.expr e in
113          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
114          Format.fprintf ppf "|- %a@\n" print_norm t;          Format.fprintf ppf "|- %a@\n" print_norm t;
115          let v = Value.eval Value.empty_env e in          let v = Value.eval !eval_env e in
116          Format.fprintf ppf "=> @[%a@]@\n" Value.print v          Format.fprintf ppf "=> @[%a@]@\n" Value.print v
117        | Ast.LetDecl (p,{descr=Ast.Abstraction _}) -> ()
118        | Ast.LetDecl (p,e) ->
119            let decl = Typer.let_decl p e in
120            type_decl decl;
121            eval_decl decl
122      | Ast.TypeDecl _ -> ()      | Ast.TypeDecl _ -> ()
123      | Ast.Debug l -> debug l      | Ast.Debug l -> debug l
124      | _ -> assert false      | _ -> assert false
125    
126    let do_fun_decls decls =
127      let decls = List.map (fun (p,e) -> Typer.let_decl p e) decls in
128      insert_type_bindings (Typer.type_rec_funs !typing_env decls);
129      List.iter eval_decl decls
130    
131    
132  let () =  let () =
133    try    try
134      let p = prog () in      let p = prog () in
135      let type_decls =      let (type_decls,fun_decls) =
136        List.fold_left        List.fold_left
137          (fun accu ph -> match ph.descr with          (fun ((typs,funs) as accu) ph -> match ph.descr with
138             | Ast.TypeDecl (x,t) -> (x,t) :: accu             | Ast.TypeDecl (x,t) -> ((x,t) :: typs,funs)
139               | Ast.LetDecl (p,({descr=Ast.Abstraction _} as e)) ->
140                   (typs, (p,e)::funs)
141             | _ -> accu             | _ -> accu
142          ) [] p in          ) ([],[]) p in
143      Typer.register_global_types type_decls;      Typer.register_global_types type_decls;
144        do_fun_decls fun_decls;
145      List.iter phrase p      List.iter phrase p
146    with    with
147      | (Failure _ | Not_found | Invalid_argument _) as e ->      | (Failure _ | Not_found | Invalid_argument _) as e ->
Legend:
Removed from v.65  
changed lines
  Added in v.66
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5