| 1 |
open Location
|
| 2 |
exception Usage
|
| 3 |
|
| 4 |
let () =
|
| 5 |
List.iter
|
| 6 |
(fun (n,t) -> Typer.register_global_types [n, mk noloc (Ast.Internal t)])
|
| 7 |
Builtin.types
|
| 8 |
|
| 9 |
|
| 10 |
let (source,input_channel) =
|
| 11 |
match Array.length Sys.argv with
|
| 12 |
| 1 -> ("",stdin)
|
| 13 |
| 2 -> let s = Sys.argv.(1) in (s, open_in s)
|
| 14 |
| _ -> raise Usage
|
| 15 |
|
| 16 |
let input = Stream.of_channel input_channel
|
| 17 |
|
| 18 |
let ppf = Format.std_formatter
|
| 19 |
let prog () =
|
| 20 |
try Parser.prog input
|
| 21 |
with
|
| 22 |
| Stdpp.Exc_located (loc, e) -> raise (Location (loc, e))
|
| 23 |
|
| 24 |
let print_norm ppf d =
|
| 25 |
Types.Print.print_descr ppf (Types.normalize d)
|
| 26 |
|
| 27 |
let rec print_exn ppf = function
|
| 28 |
| Location ((i,j), exn) ->
|
| 29 |
if source = "" then
|
| 30 |
Format.fprintf ppf "Error at chars %i-%i@\n" i j
|
| 31 |
else (
|
| 32 |
let (l1,c1) = Location.get_line_number source i
|
| 33 |
and (l2,c2) = Location.get_line_number source j in
|
| 34 |
if l1 = l2 then
|
| 35 |
Format.fprintf ppf "Error at line %i (chars %i-%i)@\n"
|
| 36 |
l1 c1 c2
|
| 37 |
else
|
| 38 |
Format.fprintf ppf "Error at lines %i (char %i) - %i (char %i)@\n"
|
| 39 |
l1 c1 l2 c2
|
| 40 |
);
|
| 41 |
print_exn ppf exn
|
| 42 |
| Typer.WrongLabel (t,l) ->
|
| 43 |
Format.fprintf ppf "Wrong record selection: the label %s@\n"
|
| 44 |
(Types.label_name l);
|
| 45 |
Format.fprintf ppf "applied to an expression of type %a@\n"
|
| 46 |
print_norm t
|
| 47 |
| Typer.MultipleLabel l ->
|
| 48 |
Format.fprintf ppf "Multiple occurences for the record label %s@\n"
|
| 49 |
(Types.label_name l);
|
| 50 |
| Typer.ShouldHave (t,msg) ->
|
| 51 |
Format.fprintf ppf "This expression should have type %a@\n%s@\n"
|
| 52 |
print_norm t
|
| 53 |
msg
|
| 54 |
| Typer.Constraint (s,t,msg) ->
|
| 55 |
Format.fprintf ppf "This expression should have type %a@\n"
|
| 56 |
print_norm t;
|
| 57 |
Format.fprintf ppf "but its infered type is: %a@\n"
|
| 58 |
print_norm s;
|
| 59 |
Format.fprintf ppf "which is not a subtype, as shown by the value %a@\n"
|
| 60 |
Types.Print.print_sample (Types.Sample.get (Types.diff s t));
|
| 61 |
Format.fprintf ppf "%s@\n" msg
|
| 62 |
| Typer.NonExhaustive t ->
|
| 63 |
Format.fprintf ppf "This pattern matching is not exhaustive@\n";
|
| 64 |
Format.fprintf ppf "Residual type: %a@\n"
|
| 65 |
print_norm t;
|
| 66 |
Format.fprintf ppf "Sample value: %a@\n"
|
| 67 |
Types.Print.print_sample (Types.Sample.get t)
|
| 68 |
| Typer.UnboundId x ->
|
| 69 |
Format.fprintf ppf "Unbound identifier %s@\n" x
|
| 70 |
| exn ->
|
| 71 |
Format.fprintf ppf "%s@\n" (Printexc.to_string exn)
|
| 72 |
|
| 73 |
let debug = function
|
| 74 |
| `Filter (t,p) ->
|
| 75 |
Format.fprintf ppf "[DEBUG:filter]@\n";
|
| 76 |
let t = Typer.typ t
|
| 77 |
and p = Typer.pat p in
|
| 78 |
let f = Patterns.filter (Types.descr t) p in
|
| 79 |
List.iter (fun (x,t) ->
|
| 80 |
Format.fprintf ppf " x:%a@\n"
|
| 81 |
print_norm (Types.descr t)) f
|
| 82 |
| `Accept p ->
|
| 83 |
Format.fprintf ppf "[DEBUG:accept]@\n";
|
| 84 |
let p = Typer.pat p in
|
| 85 |
let t = Patterns.accept p in
|
| 86 |
Format.fprintf ppf " %a@\n" Types.Print.print t
|
| 87 |
| `Compile (t,pl) ->
|
| 88 |
Format.fprintf ppf "[DEBUG:compile]@\n";
|
| 89 |
let t = Typer.typ t
|
| 90 |
and pl = List.map Typer.pat pl in
|
| 91 |
let pl = Array.of_list
|
| 92 |
(List.map (fun p -> Patterns.Compile.normal
|
| 93 |
(Patterns.descr p)) pl) in
|
| 94 |
Patterns.Compile.show ppf (Types.descr t) pl
|
| 95 |
| _ -> Format.fprintf ppf "Unknown or ill-formed debugging directive !! @\n"
|
| 96 |
let phrase ph =
|
| 97 |
match ph.descr with
|
| 98 |
| Ast.EvalStatement e ->
|
| 99 |
let (fv,e) = Typer.expr e in
|
| 100 |
let t = Typer.type_check Typer.Env.empty e Types.any true in
|
| 101 |
Format.fprintf ppf "|- %a@\n" print_norm t;
|
| 102 |
let v = Value.eval Value.empty_env e in
|
| 103 |
Format.fprintf ppf "=> @[%a@]@\n" Value.print v
|
| 104 |
| Ast.TypeDecl _ -> ()
|
| 105 |
| Ast.Debug l -> debug l
|
| 106 |
| _ -> assert false
|
| 107 |
|
| 108 |
let () =
|
| 109 |
try
|
| 110 |
let p = prog () in
|
| 111 |
let type_decls =
|
| 112 |
List.fold_left
|
| 113 |
(fun accu ph -> match ph.descr with
|
| 114 |
| Ast.TypeDecl (x,t) -> (x,t) :: accu
|
| 115 |
| _ -> accu
|
| 116 |
) [] p in
|
| 117 |
Typer.register_global_types type_decls;
|
| 118 |
List.iter phrase p
|
| 119 |
with
|
| 120 |
| (Failure _ | Not_found | Invalid_argument _) as e ->
|
| 121 |
raise e (* To get the ocamlrun stack trace *)
|
| 122 |
| exn -> print_exn ppf exn
|
| 123 |
|
| 124 |
|
| 125 |
|
| 126 |
|
| 127 |
|
Parent Directory
| 
Revision Log