Commit f9b35132 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2002-10-20 23:34:54 by cvscast] Empty log message

Original author: cvscast
Date: 2002-10-20 23:34:54+00:00
parent 3483655c
...@@ -36,6 +36,11 @@ let rec print_exn ppf = function ...@@ -36,6 +36,11 @@ let rec print_exn ppf = function
l1 c1 l2 c2 l1 c1 l2 c2
); );
print_exn ppf exn print_exn ppf exn
| Typer.WrongLabel (t,l) ->
Format.fprintf ppf "Wrong record selection: the label %s@\n"
(Types.label_name l);
(* Format.fprintf ppf "applied to an expression of type %a@\n"
(Types.Print.print_descr t) *)
| Typer.ShouldHave (t,msg) -> | Typer.ShouldHave (t,msg) ->
Format.fprintf ppf "This expression should have type %a@\n%s@\n" Format.fprintf ppf "This expression should have type %a@\n%s@\n"
Types.Print.print_descr t Types.Print.print_descr t
...@@ -77,7 +82,8 @@ let () = ...@@ -77,7 +82,8 @@ let () =
) [] p in ) [] p in
Typer.register_global_types type_decls; Typer.register_global_types type_decls;
List.iter phrase p List.iter phrase p
with (Failure _) as e -> raise e | exn -> print_exn ppf exn with (Failure _) as e -> raise e
| exn -> print_exn ppf exn
......
...@@ -32,7 +32,7 @@ and pexpr' = ...@@ -32,7 +32,7 @@ and pexpr' =
| Op of string * pexpr list | Op of string * pexpr list
| Match of pexpr * branches | Match of pexpr * branches
| Map of pexpr * branches | Map of pexpr * branches
| Dot of (pexpr* Types.label)
and abstr = { and abstr = {
fun_name : string option; fun_name : string option;
fun_iface : (ppat * ppat) list; fun_iface : (ppat * ppat) list;
......
...@@ -69,7 +69,9 @@ open Ast ...@@ -69,7 +69,9 @@ open Ast
| e1 = expr; "@"; e2 = expr -> mk loc (Op ("@",[e1;e2])) ] | e1 = expr; "@"; e2 = expr -> mk loc (Op ("@",[e1;e2])) ]
| |
[ e1 = expr; "*"; e2 = expr -> mk loc (Op ("*",[e1;e2])) ] [ e1 = expr; "*"; e2 = expr -> mk loc (Op ("*",[e1;e2])) ]
|
[ e = expr; "."; l = [LIDENT | UIDENT] -> mk loc (Dot (e,Types.label l)) ]
| "no_appl" | "no_appl"
[ c = const -> mk loc (Cst c) [ c = const -> mk loc (Cst c)
| "("; l = LIST1 expr SEP ","; ")" -> tuple loc l | "("; l = LIST1 expr SEP ","; ")" -> tuple loc l
......
...@@ -179,7 +179,6 @@ end ...@@ -179,7 +179,6 @@ end
module Print : module Print :
sig sig
val register_global : string -> descr -> unit val register_global : string -> descr -> unit
val print : Format.formatter -> node -> unit val print : Format.formatter -> node -> unit
val print_descr: Format.formatter -> descr -> unit val print_descr: Format.formatter -> descr -> unit
val print_sample : Format.formatter -> Sample.t -> unit val print_sample : Format.formatter -> Sample.t -> unit
......
...@@ -35,6 +35,7 @@ and texpr' = ...@@ -35,6 +35,7 @@ and texpr' =
| Op of string * texpr list | Op of string * texpr list
| Match of texpr * branches | Match of texpr * branches
| Map of texpr * branches | Map of texpr * branches
| Dot of (texpr * Types.label)
and abstr = { and abstr = {
fun_name : string option; fun_name : string option;
......
...@@ -8,6 +8,7 @@ exception Pattern of string ...@@ -8,6 +8,7 @@ exception Pattern of string
exception NonExhaustive of Types.descr exception NonExhaustive of Types.descr
exception Constraint of Types.descr * Types.descr * string exception Constraint of Types.descr * Types.descr * string
exception ShouldHave of Types.descr * string exception ShouldHave of Types.descr * string
exception WrongLabel of Types.descr * Types.label
let raise_loc loc exn = raise (Location (loc,exn)) let raise_loc loc exn = raise (Location (loc,exn))
...@@ -327,6 +328,9 @@ let rec expr { loc = loc; descr = d } = ...@@ -327,6 +328,9 @@ let rec expr { loc = loc; descr = d } =
| Pair (e1,e2) -> | Pair (e1,e2) ->
let (fv1,e1) = expr e1 and (fv2,e2) = expr e2 in let (fv1,e1) = expr e1 and (fv2,e2) = expr e2 in
(Fv.union fv1 fv2, Typed.Pair (e1,e2)) (Fv.union fv1 fv2, Typed.Pair (e1,e2))
| Dot (e,l) ->
let (fv,e) = expr e in
(Fv.union Fv.empty fv, Typed.Dot (e,l))
| RecordLitt r -> | RecordLitt r ->
(* XXX TODO: check that no label appears twice *) (* XXX TODO: check that no label appears twice *)
let fv = ref Fv.empty in let fv = ref Fv.empty in
...@@ -447,6 +451,10 @@ and compute_type' loc env = function ...@@ -447,6 +451,10 @@ and compute_type' loc env = function
else else
(ignore (type_check env e2 dom false); Types.Arrow.apply_noarg t1) (ignore (type_check env e2 dom false); Types.Arrow.apply_noarg t1)
| Cst c -> Types.constant c | Cst c -> Types.constant c
| Dot (e,l) ->
let t = type_check env e Types.Record.any true in
(try (Types.Record.project t l)
with Not_found -> raise_loc loc (WrongLabel(t,l)))
| RecordLitt r -> | RecordLitt r ->
List.fold_left List.fold_left
(fun accu (l,e) -> (fun accu (l,e) ->
......
...@@ -2,6 +2,7 @@ exception Pattern of string ...@@ -2,6 +2,7 @@ exception Pattern of string
exception NonExhaustive of Types.descr exception NonExhaustive of Types.descr
exception Constraint of Types.descr * Types.descr * string exception Constraint of Types.descr * Types.descr * string
exception ShouldHave of Types.descr * string exception ShouldHave of Types.descr * string
exception WrongLabel of Types.descr * Types.label
val compile_regexp : Ast.regexp -> Ast.ppat -> Ast.ppat val compile_regexp : Ast.regexp -> Ast.ppat -> Ast.ppat
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment