/[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 1073 by abate, Tue Jul 10 18:20:48 2007 UTC
# Line 1  Line 1 
1  open Location  open Location
2  open Ident  open Ident
3    
4  let quiet = ref false  ifdef ML_INTERFACE then module ML = Ml_ocaml;;
5    
6  let typing_env = State.ref "Cduce.typing_env" Typer.Env.empty  exception InvalidInputFilename of string
7  let glb_env = State.ref "Cduce.glb_env" Typer.TypeEnv.empty  exception InvalidObjectFilename of string
8  let eval_env = Eval.global_env  
9    (* if set to false toplevel exception aren't cought.
10     * Useful for debugging with OCAMLRUNPARAM="b" *)
11    let catch_exceptions = true
12    
13    (* retuns a filename without the suffix suff if any *)
14    let prefix filename suff =
15      if Filename.check_suffix filename suff then
16        try
17          Filename.chop_extension filename
18        with Invalid_argument filename -> failwith "Not a point in the suffix?"
19      else filename
20    
21    let toplevel = ref false
22    let verbose = ref false
23    
24    let typing_env = State.ref "Cduce.typing_env" Builtin.env
25    let compile_env = State.ref "Cduce.compile_env" Compile.empty
26    
27    let get_global_value cenv v =
28      Eval.var (Compile.find v !compile_env)
29    
30    let get_global_type v =
31      Typer.find_value v !typing_env
32    
33    let enter_global_value x v t =
34      typing_env := Typer.enter_value x t !typing_env;
35      compile_env := Compile.enter_global !compile_env x;
36      Eval.push v
37    
38    let rec is_abstraction = function
39      | Ast.Abstraction _ -> true
40      | Ast.LocatedExpr (_,e) -> is_abstraction e
41      | _ -> false
42    
43  let print_norm ppf d =  let print_norm ppf d =
44    Location.protect ppf    Location.protect ppf
45      (fun ppf -> Types.Print.print_descr ppf ((*Types.normalize*) d))      (fun ppf -> Types.Print.print ppf ((*Types.normalize*) d))
46    
47    let print_sample ppf s =
48      Location.protect ppf
49        (fun ppf -> Sample.print ppf s)
50    
51    let print_protect ppf s =
52      Location.protect ppf (fun ppf -> Format.fprintf ppf "%s" s)
53    
54  let print_value ppf v =  let print_value ppf v =
55    Location.protect ppf (fun ppf -> Value.print ppf v)    Location.protect ppf (fun ppf -> Value.print ppf v)
56    
57  let dump_env ppf =  let dump_value ppf x t v =
58    Format.fprintf ppf "Global types:";    Format.fprintf ppf "@[val %a : @[%a = %a@]@]@."
59    Typer.TypeEnv.iter (fun x _ -> Format.fprintf ppf " %s" x) !glb_env;      U.print (Id.value x) print_norm t print_value v
60    Format.fprintf ppf ".@\n";  
61    Eval.Env.iter  let dump_env ppf tenv cenv =
62      (fun x v ->    Format.fprintf ppf "Types:%a@." Typer.dump_types tenv;
63         let t = Typer.Env.find x !typing_env in    Format.fprintf ppf "Namespace prefixes:@\n%a" Typer.dump_ns tenv;
64         Format.fprintf ppf "@[|- %s : %a@ => %a@]@\n"    Format.fprintf ppf "Namespace prefixes used for pretty-printing:@.%t"
65           (Id.value x)      Ns.InternalPrinter.dump;
66           print_norm t    Format.fprintf ppf "Schemas: %s@."
67           print_value v      (String.concat " " (List.map U.get_str (Typer.get_schema_names ())));
68      )    Format.fprintf ppf "Values:@.";
69      !eval_env    Typer.iter_values tenv
70        (fun x t -> dump_value ppf x t (get_global_value cenv x))
71    
72    let directive_help ppf =
73      Format.fprintf ppf
74    "Toplevel directives:
75      #quit;;                 quit the interpreter
76      #env;;                  dump current environment
77      #reinit_ns;;            reinitialize namespace processing
78      #help;;                 shows this help message
79      #dump_value <expr>;;    dump an XML-ish representation of the resulting
80                              value of a given expression
81      #print_schema <name>;;
82      #print_type <name>;;
83    "
84    
85  let rec print_exn ppf = function  let rec print_exn ppf = function
86    | Location (loc, exn) ->    | Location (loc, w, exn) ->
87        Format.fprintf ppf "Error %a:@\n" Location.print_loc loc;        Format.fprintf ppf "Error %a:@." Location.print_loc (loc,w);
88        Format.fprintf ppf "%a" Location.html_hilight loc;        Format.fprintf ppf "%a" Location.html_hilight (loc,w);
89        print_exn ppf exn        print_exn ppf exn
90    | Value.CDuceExn v ->    | Value.CDuceExn v ->
91        Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@\n"        Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@."
92          print_value v          print_value v
93    | Typer.WrongLabel (t,l) ->    | Typer.WrongLabel (t,l) ->
94        Format.fprintf ppf "Wrong record selection: the label %s@\n"        Format.fprintf ppf "Wrong record selection; field %a "
95          (LabelPool.value l);          Label.print (LabelPool.value l);
96        Format.fprintf ppf "applied to an expression of type %a@\n"        Format.fprintf ppf "not present in an expression of type:@.%a@."
97          print_norm t          print_norm t
98    | Typer.ShouldHave (t,msg) ->    | Typer.ShouldHave (t,msg) ->
99        Format.fprintf ppf "This expression should have type %a@\n%s@\n"        Format.fprintf ppf "This expression should have type:@.%a@.%a@."
100          print_norm t          print_norm t
101          msg          print_protect msg
102    | Typer.Constraint (s,t,msg) ->    | Typer.ShouldHave2 (t1,msg,t2) ->
103        Format.fprintf ppf "This expression should have type %a@\n"        Format.fprintf ppf "This expression should have type:@.%a@.%a %a@."
104            print_norm t1
105            print_protect msg
106            print_norm t2
107      | Typer.Error s ->
108          Format.fprintf ppf "%a@." print_protect s
109      | Typer.Constraint (s,t) ->
110          Format.fprintf ppf "This expression should have type:@.%a@."
111          print_norm t;          print_norm t;
112        Format.fprintf ppf "but its infered type is: %a@\n"        Format.fprintf ppf "but its inferred type is:@.%a@."
113          print_norm s;          print_norm s;
114        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@."
115          Types.Sample.print (Types.Sample.get (Types.diff s t));          print_sample (Sample.get (Types.diff s t))
       Format.fprintf ppf "%s@\n" msg  
116    | Typer.NonExhaustive t ->    | Typer.NonExhaustive t ->
117        Format.fprintf ppf "This pattern matching is not exhaustive@\n";        Format.fprintf ppf "This pattern matching is not exhaustive@.";
118        Format.fprintf ppf "Residual type: %a@\n"        Format.fprintf ppf "Residual type:@.%a@."
119          print_norm t;          print_norm t;
120        Format.fprintf ppf "Sample value: %a@\n"        Format.fprintf ppf "Sample:@.%a@." print_sample (Sample.get t)
121          Types.Sample.print (Types.Sample.get t)    | Typer.UnboundId (x,tn) ->
122    | Typer.UnboundId x ->        Format.fprintf ppf "Unbound identifier %a%s@." U.print (Id.value x)
123        Format.fprintf ppf "Unbound identifier %s@\n" x          (if tn then " (it is a type name)" else "")
124    | Wlexer.Illegal_character c ->    | Ulexer.Error (i,j,s) ->
125        Format.fprintf ppf "Illegal character (%s)@\n" (Char.escaped c)        let loc = Location.loc_of_pos (i,j), `Full in
126    | Wlexer.Unterminated_comment ->        Format.fprintf ppf "Error %a:@." Location.print_loc loc;
127        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"  
128    | Parser.Error s | Stream.Error s ->    | Parser.Error s | Stream.Error s ->
129        Format.fprintf ppf "Parsing error: %s@\n" s        Format.fprintf ppf "Parsing error: %a@." print_protect s
130      | Librarian.InconsistentCrc id ->
131          Format.fprintf ppf "Link error:@.";
132          let name = Encodings.Utf8.to_string (Types.CompUnit.value id) in
133          Format.fprintf ppf "Inconsistent checksum (compilation unit: %s)@."
134            name
135      | Librarian.NoImplementation id ->
136          Format.fprintf ppf "Link error:@.";
137          let name = Encodings.Utf8.to_string (Types.CompUnit.value id) in
138          Format.fprintf ppf "No implementation found for compilation unit: %s@."
139            name
140      | Librarian.Loop id ->
141          Format.fprintf ppf "Compilation error:@.";
142          let name = Encodings.Utf8.to_string (Types.CompUnit.value id) in
143          Format.fprintf ppf "Loop between compilation unit (compilation unit: %s)@."
144            name
145      | InvalidInputFilename f ->
146          Format.fprintf ppf "Compilation error:@.";
147          Format.fprintf ppf "Source filename must have extension .cd@.";
148      | InvalidObjectFilename f ->
149          Format.fprintf ppf "Compilation error:@.";
150          Format.fprintf ppf "Object filename must have extension .cdo and no path@.";
151      | Librarian.InvalidObject f ->
152          Format.fprintf ppf "Invalid object file %s@." f
153      | Librarian.CannotOpen f ->
154          Format.fprintf ppf "Cannot open file %s@." f
155    | Location.Generic s ->    | Location.Generic s ->
156        Format.fprintf ppf "%s@\n" s        Format.fprintf ppf "%a@." print_protect s
157    | exn ->    | exn ->
158        raise exn  (*      raise exn *)
159  (*        Format.fprintf ppf "%a@." print_protect (Printexc.to_string exn)
160        Format.fprintf ppf "%s@\n" (Printexc.to_string exn)  
 *)  
161    
162  let debug ppf = function  let eval_quiet tenv cenv e =
163      let (e,_) = Typer.type_expr tenv e in
164      let e = Compile.compile_eval cenv e in
165      Eval.expr e
166    
167    let debug ppf tenv cenv = function
168    | `Subtype (t1,t2) ->    | `Subtype (t1,t2) ->
169        Format.fprintf ppf "[DEBUG:subtype]@\n";        Format.fprintf ppf "[DEBUG:subtype]@.";
170        let t1 = Types.descr (Typer.typ !glb_env t1)        let t1 = Types.descr (Typer.typ tenv t1)
171        and t2 = Types.descr (Typer.typ !glb_env t2) in        and t2 = Types.descr (Typer.typ tenv t2) in
172        Format.fprintf ppf "%a <= %a : %b@\n" print_norm t1 print_norm t2        let s = Types.subtype t1 t2 in
173          (Types.subtype t1 t2)        Format.fprintf ppf "%a %a %a : %b@." print_norm t1 print_protect "<=" print_norm t2 s
174      | `Sample t ->
175          Format.fprintf ppf "[DEBUG:sample]@.";
176          (try
177             let t = Types.descr (Typer.typ tenv t) in
178             Format.fprintf ppf "%a@." print_sample (Sample.get t)
179           with Not_found ->
180             Format.fprintf ppf "Empty type : no sample !@.")
181    | `Filter (t,p) ->    | `Filter (t,p) ->
182        Format.fprintf ppf "[DEBUG:filter]@\n";        Format.fprintf ppf "[DEBUG:filter]@.";
183        let t = Typer.typ !glb_env t        let t = Typer.typ tenv t
184        and p = Typer.pat !glb_env p in        and p = Typer.pat tenv p in
185        let f = Patterns.filter (Types.descr t) p in        let f = Patterns.filter (Types.descr t) p in
186        List.iter (fun (x,t) ->        List.iter (fun (x,t) ->
187                     Format.fprintf ppf " %s:%a@\n" (Id.value x)                     Format.fprintf ppf " %a:%a@." U.print (Id.value x)
188                       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 *)  
       ()  
   
189    | `Accept p ->    | `Accept p ->
190        Format.fprintf ppf "[DEBUG:accept]@\n";        Format.fprintf ppf "[DEBUG:accept]@.";
191        let p = Typer.pat !glb_env p in        let p = Typer.pat tenv p in
192        let t = Patterns.accept p in        let t = Patterns.accept p in
193        Format.fprintf ppf " %a@\n" Types.Print.print t        Format.fprintf ppf " %a@." Types.Print.print (Types.descr t)
194    | `Compile (t,pl) ->    | `Compile (t,pl) ->
195        Format.fprintf ppf "[DEBUG:compile]@\n";        Format.fprintf ppf "[DEBUG:compile]@.";
196        let t = Typer.typ !glb_env t        let t = Typer.typ tenv t
197        and pl = List.map (Typer.pat !glb_env) pl in        and pl = List.map (Typer.pat tenv) pl in
198        Patterns.Compile.debug_compile ppf t pl        Patterns.Compile.debug_compile ppf t pl
199    | `Normal_record p -> assert false    | `Explain (t,e) ->
200          Format.fprintf ppf "[DEBUG:explain]@.";
201          let t = Typer.typ tenv t in
202          (match Explain.explain (Types.descr t) (eval_quiet tenv cenv e) with
203             | Some p ->
204                 Format.fprintf ppf "Explanation: @[%a@]@."
205                   Explain.print_path p
206             | None ->
207                 Format.fprintf ppf "Explanation: value has given type@.")
208    
209    
210    let flush_ppf ppf = Format.fprintf ppf "@."
211    
212    let directive ppf tenv cenv = function
213      | `Debug d ->
214          debug ppf tenv cenv d
215      | `Quit ->
216          (if !toplevel then raise End_of_file)
217      | `Env ->
218          dump_env ppf tenv cenv
219      | `Print_schema schema ->
220          Schema_common.print_schema ppf (Typer.get_schema schema);
221          flush_ppf ppf
222      | `Print_type name ->
223          Typer.dump_type ppf tenv name;
224          flush_ppf ppf
225      | `Print_schema_type schema_ref ->
226          Typer.dump_schema_type ppf schema_ref;
227          flush_ppf ppf
228      | `Reinit_ns ->
229          Typer.set_ns_table_for_printer tenv
230      | `Help ->
231          directive_help ppf
232      | `Dump pexpr ->
233          Value.dump_xml ppf (eval_quiet tenv cenv pexpr);
234          flush_ppf ppf
235    
236    let print_id_opt ppf = function
237      | None -> Format.fprintf ppf "-"
238      | Some id -> Format.fprintf ppf "val %a" U.print (Id.value id)
239    
240    let print_value_opt ppf = function
241      | None -> ()
242      | Some v -> Format.fprintf ppf " = %a" print_value v
243    
244    let show ppf id t v =
245      Format.fprintf ppf "@[%a : @[%a%a@]@]@."
246        print_id_opt id
247        print_norm t
248        print_value_opt v
249    
250    let phrases ppf phs =
251      let (tenv,cenv,_) =
252        Compile.comp_unit
253          ~run:true ~show:(show ppf)
254          ~loading:(fun cu -> Librarian.import cu; Librarian.run Value.nil cu)
255          ~directive:(directive ppf)
256          !typing_env !compile_env phs in
257      typing_env := tenv;
258      compile_env := cenv
259    
260    let catch_exn ppf_err exn =
261      if not catch_exceptions then raise exn;
262      match exn with
263      | (End_of_file | Failure _ | Not_found | Invalid_argument _ | Sys.Break)
264          as e ->
265          raise e
266      | exn ->
267          print_exn ppf_err exn;
268          Format.fprintf ppf_err "@."
269    
270  let mk_builtin () =  let parse rule input =
271    let bi = List.map (fun (n,t) -> [n, mknoloc (Ast.Internal t)])    try Parser.localize_exn (fun () -> rule input)
272               Builtin.types in    with e -> Parser.sync (); raise e
273    glb_env := List.fold_left Typer.register_global_types !glb_env bi  
274    let run rule ppf ppf_err input =
275      try phrases ppf (parse rule input); true
276      with exn -> catch_exn ppf_err exn; false
277    
278    let script = run Parser.prog
279    let topinput = run Parser.top_phrases
280    
281    ifdef ML_INTERFACE then
282      let check_ml cu id out_dir out =
283        let fnam = String.copy cu in
284        String.set fnam 0 ( Char.lowercase ( String.get fnam 0 ) );
285        try
286          let name = fnam ^ ".cmi" in
287          let file = List.find (
288            fun dir -> Sys.file_exists ( Filename.concat dir name )
289          ) !Librarian.obj_path in
290          if file = "" then raise Not_found;
291          let file = Filename.concat file name in
292          let ml_cu = ML.CompUnit.from_bytecode file cu
293          and cd_cu = Ml_cduce.CompUnit.from_types_cu cu id in
294          Ml_checker.run ml_cu cd_cu;
295          let out = open_out ( Filename.concat out_dir (cu ^ ".ml") ) in
296          let fmt = Format.formatter_of_out_channel out in
297          Ml_generator.ML.generate fmt ml_cu cd_cu;
298          close_out out;
299        with Not_found -> (
300          let name = fnam ^ ".mli" in
301          let has_cmi = List.exists (
302            fun dir -> Sys.file_exists ( Filename.concat dir name )
303          ) !Librarian.obj_path in
304          if has_cmi then
305            Format.eprintf
306              "Warning: found %s.mli but no %s.cmi: forgotten compilation?@."
307              fnam fnam;
308        )
309    else
310      let check_ml cu id out_dir out = ();;
311    
312  let () = mk_builtin ()  let compile src out_dir =
313      try
314        if not (Filename.check_suffix src ".cd")
315        then raise (InvalidInputFilename src);
316        let cu = Filename.chop_suffix (Filename.basename src) ".cd" in
317        let out_dir =
318          match out_dir with
319            | None -> Filename.dirname src
320            | Some x -> x in
321        let out = Filename.concat out_dir (cu ^ ".cdo") in
322        let id = Types.CompUnit.mk (U.mk_latin1 cu) in
323        Librarian.compile !verbose id src;
324        Librarian.save id out;
325        check_ml cu id out_dir out;
326        exit 0
327      with exn -> catch_exn Format.err_formatter exn; exit 1
328    
329    let compile_run src argv =
330      try
331        if not (Filename.check_suffix src ".cd")
332        then raise (InvalidInputFilename src);
333        let cu = Filename.chop_suffix (Filename.basename src) ".cd" in
334        let id = Types.CompUnit.mk (U.mk_latin1 cu) in
335        Librarian.compile !verbose id src;
336        Librarian.run argv id
337      with exn -> catch_exn Format.err_formatter exn; exit 1
338    
339  let run ppf ppf_err input =  let run obj argv =
   let insert_type_bindings =  
     List.iter (fun (x,t) ->  
                  typing_env := Typer.Env.add x t !typing_env;  
                  if not !quiet then  
                    Format.fprintf ppf "|- %s : %a@\n@." (Id.value x) print_norm t)  
   in  
   
   let type_decl decl =  
     insert_type_bindings (Typer.type_let_decl !typing_env decl)  
   in  
   
   let eval_decl decl =  
     let bindings = Eval.eval_let_decl Eval.Env.empty decl in  
     List.iter  
       (fun (x,v) ->  
          Eval.enter_global x v;  
          if not !quiet then  
            Format.fprintf ppf "=> %s : @[%a@]@\n@." (Id.value x) print_value v  
       ) bindings  
   in  
   
   let phrase ph =  
     match ph.descr with  
       | Ast.EvalStatement e ->  
           let (fv,e) = Typer.expr !glb_env e in  
           let t = Typer.type_check !typing_env e Types.any true in  
           Location.dump_loc ppf e.Typed.exp_loc;  
           if not !quiet then  
             Format.fprintf ppf "|- %a@\n@." print_norm t;  
           let v = Eval.eval Eval.Env.empty e in  
           if not !quiet then  
             Format.fprintf ppf "=> @[%a@]@\n@." print_value v  
       | Ast.LetDecl (p,{descr=Ast.Abstraction _}) -> ()  
       | Ast.LetDecl (p,e) ->  
           let decl = Typer.let_decl !glb_env p e in  
           type_decl decl;  
           eval_decl decl  
       | Ast.TypeDecl _ -> ()  
       | Ast.Debug l -> debug ppf l  
       | _ -> assert false  
   in  
   
   let do_fun_decls decls =  
     let decls = List.map (fun (p,e) -> Typer.let_decl !glb_env p e) decls in  
     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  
340    try    try
341      let p =      if not (Filename.check_suffix obj ".cdo") || (Filename.basename obj <> obj)
342        try Parser.prog input      then raise (InvalidObjectFilename obj);
343        with      let cu = Filename.chop_suffix (Filename.basename obj) ".cdo" in
344          | Stdpp.Exc_located (_, (Location _ as e)) -> raise e      let id = Types.CompUnit.mk (U.mk_latin1 cu) in
345          | Stdpp.Exc_located ((i,j), e) -> raise_loc i j e      Librarian.import id;
346      in      Librarian.run argv id
347      let (type_decls,fun_decls) =    with exn -> catch_exn Format.err_formatter exn; exit 1
       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;  
     true  
   with  
     | (Failure _ | Not_found | Invalid_argument _) as e ->  
         raise e  (* To get ocamlrun stack trace *)  
     | exn -> print_exn ppf_err exn; false  
348    
349    
350    let dump_env ppf = dump_env ppf !typing_env !compile_env
Legend:
Removed from v.249  
changed lines
  Added in v.1073
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5