Commit 960d71e8 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2002-10-21 18:58:02 by cvscast] Empty log message

Original author: cvscast
Date: 2002-10-21 18:58:02+00:00
parent 5bc6df74
......@@ -21,6 +21,9 @@ let prog () =
with
| Stdpp.Exc_located (loc, e) -> raise (Location (loc, e))
let print_norm ppf d =
Types.Print.print_descr ppf (Types.normalize d)
let rec print_exn ppf = function
| Location ((i,j), exn) ->
if source = "" then
......@@ -40,26 +43,26 @@ let rec print_exn ppf = function
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
print_norm t
| Typer.MultipleLabel l ->
Format.fprintf ppf "Multiple occurences for the record label %s@\n"
(Types.label_name l);
| Typer.ShouldHave (t,msg) ->
Format.fprintf ppf "This expression should have type %a@\n%s@\n"
Types.Print.print_descr t
print_norm t
msg
| Typer.Constraint (s,t,msg) ->
Format.fprintf ppf "This expression should have type %a@\n"
Types.Print.print_descr t;
print_norm t;
Format.fprintf ppf "but its infered type is: %a@\n"
Types.Print.print_descr s;
print_norm s;
Format.fprintf ppf "which is not a subtype, as shown by the value %a@\n"
Types.Print.print_sample (Types.Sample.get (Types.diff s t));
Format.fprintf ppf "%s@\n" msg
| Typer.NonExhaustive t ->
Format.fprintf ppf "This pattern matching is not exhaustive@\n";
Format.fprintf ppf "Residual type: %a@\n"
Types.Print.print_descr t;
print_norm t;
Format.fprintf ppf "Sample value: %a@\n"
Types.Print.print_sample (Types.Sample.get t)
| exn ->
......
......@@ -454,8 +454,13 @@ struct
let restrict_label_present t l =
let aux = SortedMap.change l (fun (_,d) -> (false,d)) (false,any) in
List.map aux t
let restr = function
| (true, d) -> if non_empty d then (false,d) else raise Exit
| x -> x in
let aux accu r =
try SortedMap.change l restr (false,any) r :: accu
with Exit -> accu in
List.fold_left aux [] t
let restrict_label_absent t l =
let restr = function (true, _) -> (true,empty) | _ -> raise Exit in
......@@ -481,6 +486,9 @@ struct
in
List.fold_left aux empty t
let project d l =
project_field (get_record d.record) l
type normal =
[ `Success
| `Fail
......@@ -519,31 +527,33 @@ struct
let normal d =
List.fold_left merge_record `Fail (get d)
let project d l =
let aux accu x =
match List.assoc l x with
| (false,t) -> cup accu t
| _ -> raise Not_found
in
List.fold_left aux empty (get_record d.record)
let any = { empty with record = any.record }
let is_empty d = d = []
end
module DescrHash =
Hashtbl.Make(
struct
type t = descr
let hash = hash_descr
let equal = equal_descr
end
)
module MapDescr = Map.Make(struct type t = descr let compare = compare end)
let memo_normalize = ref MapDescr.empty
let memo_normalize = DescrHash.create 17
let map_sort f l =
SortedList.from_list (List.map f l)
let rec rec_normalize d =
try MapDescr.find d !memo_normalize
try DescrHash.find memo_normalize d
with Not_found ->
let n = make () in
memo_normalize := MapDescr.add d n !memo_normalize;
DescrHash.add memo_normalize d n;
let times =
map_sort
(fun (d1,d2) -> [(rec_normalize d1, rec_normalize d2)],[])
......@@ -558,16 +568,7 @@ let rec rec_normalize d =
n
let normalize n =
internalize (rec_normalize (descr n))
module DescrHash =
Hashtbl.Make(
struct
type t = descr
let hash = hash_descr
let equal = equal_descr
end
)
descr (internalize (rec_normalize n))
module Print =
struct
......
......@@ -151,7 +151,7 @@ module Atom : sig
val has_atom : descr -> atom -> bool
end
val normalize : node -> node
val normalize : descr -> descr
(** Subtyping and sample values **)
......
......@@ -333,7 +333,10 @@ let rec expr { loc = loc; descr = d } =
let (fv,e) = expr e in
(fv, Typed.Dot (e,l))
| RecordLitt r ->
(* XXX TODO: check that no label appears twice *)
(* Note: quadratic check for non duplication of labels.
Should improve that to O(n log n) for dealing
with huge number of attributes ?
*)
let fv = ref Fv.empty in
let labs = ref [] in
let r = List.map
......@@ -435,6 +438,35 @@ and type_check' loc env e constr precise = match e with
Types.times (Types.cons t1) (Types.cons t2)
else
constr
| RecordLitt r ->
let rconstr = Types.Record.get constr in
if Types.Record.is_empty rconstr then
raise_loc loc (ShouldHave (constr,"but it is a record."));
let (rconstr,res) =
List.fold_left
(fun (rconstr,res) (l,e) ->
let rconstr = Types.Record.restrict_label_present rconstr l in
let pi = Types.Record.project_field rconstr l in
if Types.Record.is_empty rconstr then
raise_loc loc
(ShouldHave (constr,(Printf.sprintf
"Field %s is not allowed here."
(Types.label_name l)
)
));
let t = type_check env e pi true in
let rconstr = Types.Record.restrict_field rconstr l t in
let res =
if precise
then Types.cap res (Types.record l false (Types.cons t))
else res in
(rconstr,res)
) (rconstr, if precise then Types.Record.any else constr) r
in
res
| _ ->
let t : Types.descr = compute_type' loc env e in
check loc t constr "";
......@@ -460,13 +492,6 @@ and compute_type' loc env = function
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) ->
let t = compute_type env e in
let t = Types.record l false (Types.cons t) in
Types.cap accu t
) Types.Record.any r
| Op (op, el) ->
let args = List.map (fun e -> (e.exp_loc, compute_type env e)) el in
type_op loc op args
......
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