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
l1 c1 l2 c2
);
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) ->
Format.fprintf ppf "This expression should have type %a@\n%s@\n"
Types.Print.print_descr t
......@@ -77,7 +82,8 @@ let () =
) [] p in
Typer.register_global_types type_decls;
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' =
| Op of string * pexpr list
| Match of pexpr * branches
| Map of pexpr * branches
| Dot of (pexpr* Types.label)
and abstr = {
fun_name : string option;
fun_iface : (ppat * ppat) list;
......
......@@ -69,7 +69,9 @@ open Ast
| 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"
[ c = const -> mk loc (Cst c)
| "("; l = LIST1 expr SEP ","; ")" -> tuple loc l
......
......@@ -179,7 +179,6 @@ end
module Print :
sig
val register_global : string -> descr -> unit
val print : Format.formatter -> node -> unit
val print_descr: Format.formatter -> descr -> unit
val print_sample : Format.formatter -> Sample.t -> unit
......
......@@ -35,6 +35,7 @@ and texpr' =
| Op of string * texpr list
| Match of texpr * branches
| Map of texpr * branches
| Dot of (texpr * Types.label)
and abstr = {
fun_name : string option;
......
......@@ -8,6 +8,7 @@ exception Pattern of string
exception NonExhaustive of Types.descr
exception Constraint of Types.descr * 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))
......@@ -327,6 +328,9 @@ let rec expr { loc = loc; descr = d } =
| Pair (e1,e2) ->
let (fv1,e1) = expr e1 and (fv2,e2) = expr e2 in
(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 ->
(* XXX TODO: check that no label appears twice *)
let fv = ref Fv.empty in
......@@ -447,6 +451,10 @@ and compute_type' loc env = function
else
(ignore (type_check env e2 dom false); Types.Arrow.apply_noarg t1)
| 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 ->
List.fold_left
(fun accu (l,e) ->
......
......@@ -2,6 +2,7 @@ exception Pattern of string
exception NonExhaustive of Types.descr
exception Constraint of Types.descr * 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
......
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