Commit 7c7455a8 authored by Pietro Abate's avatar Pietro Abate
Browse files

Add Type check for parametric types arguments

parent 08a5a432
...@@ -287,29 +287,30 @@ let deferr s = raise (Patterns.Error s) ...@@ -287,29 +287,30 @@ let deferr s = raise (Patterns.Error s)
(* From the intermediate representation to the internal one *) (* From the intermediate representation to the internal one *)
let rec typ n = let rec typ ?(err=deferr) n =
let n = repr n in let n = repr n in
match n.t with match n.t with
| Some t -> t | Some t -> t
| None -> let t = compute_typ n.desc in n.t <- Some t; t | None -> let t = compute_typ err n.desc in n.t <- Some t; t
and compute_typ = function and compute_typ err = function
| IType (t,_) -> t | IType (t,_) -> t
| IOr (s1,s2,_) -> Types.cup (typ s1) (typ s2) | IOr (s1,s2,_) -> Types.cup (typ s1) (typ s2)
| IAnd (s1,s2,_) -> Types.cap (typ s1) (typ s2) | IAnd (s1,s2,_) -> Types.cap (typ s1) (typ s2)
| IDiff (s1,s2,_) -> Types.diff (typ s1) (typ s2) | IDiff (s1,s2,_) -> Types.diff (typ s1) (typ s2)
| ITimes (s1,s2) -> Types.times (typ_node s1) (typ_node s2) | ITimes (s1,s2) -> Types.times (typ_node s1) (typ_node s2)
| IXml (s1,s2) -> Types.xml (typ_node s1) (typ_node s2) | IXml (s1,s2) -> Types.xml (typ_node s1) (typ_node s2)
| IArrow (s1,s2) -> Types.arrow (typ_node s1) (typ_node s2) | IArrow (s1,s2) -> Types.arrow (typ_node s1) (typ_node s2)
| IOptional (s,_) -> Types.Record.or_absent (typ s) | IOptional (s,_) -> Types.Record.or_absent (typ s)
| IRecord (o,r,err) -> | IRecord (o,r,err) ->
Types.record_fields (o, LabelMap.map (compute_typ_field err) r) Types.record_fields (o, LabelMap.map (compute_typ_field err) r)
| ILink _ -> assert false | ILink _ -> assert false
| ICapture _ | IConstant (_,_) -> assert false | ICapture x | IConstant (x,_) ->
| IConcat _ | IMerge _ -> assert false raise (err ("Identifier "^(to_string x)^" is not a valid type"))
and compute_typ_field err = function | IConcat _ | IMerge _ -> assert false
| (s, None) -> typ_node s and compute_typ_field err = function
| (s, Some _) -> | (s, None) -> typ_node s
raise (err "Or-else clauses are not allowed in types") | (s, Some _) ->
raise (err "Or-else clauses are not allowed in types")
and typ_node n = and typ_node n =
let n = repr n in let n = repr n in
......
...@@ -26,7 +26,7 @@ val internalize: node -> unit ...@@ -26,7 +26,7 @@ val internalize: node -> unit
val peek_fv: node -> id option val peek_fv: node -> id option
val typ : node -> Types.descr val typ : ?err:err -> node -> Types.descr
val typ_node : node -> Types.Node.t val typ_node : node -> Types.Node.t
val pat_node : node -> Patterns.node val pat_node : node -> Patterns.node
......
...@@ -394,10 +394,20 @@ module IType = struct ...@@ -394,10 +394,20 @@ module IType = struct
let a = Array.of_list a in let a = Array.of_list a in
let l = ref [] in let l = ref [] in
for i=0 to (Array.length pargs) - 1 do for i=0 to (Array.length pargs) - 1 do
l := (pargs.(i), typ(derecurs env a.(i)))::!l try
let err s = Error s in
l := (pargs.(i), typ ~err (derecurs env a.(i)))::!l
with
|Error s -> raise_loc_generic loc s
|_ -> assert false
done; done;
mk_type (Types.Positive.substitute_list t !l) mk_type (Types.Positive.substitute_list t !l)
with Not_found -> mk_capture v with Not_found ->
if List.length a >= 1 then
raise_loc_generic loc
(Printf.sprintf "Parametric type %s does not exists" (Ident.to_string v))
else
mk_capture v
end end
| (ids,_) -> | (ids,_) ->
mk_type (fst(find_global_type env.penv_tenv loc ids)) mk_type (fst(find_global_type env.penv_tenv loc ids))
...@@ -533,7 +543,6 @@ let pat_false = ...@@ -533,7 +543,6 @@ let pat_false =
Patterns.define n (Patterns.constr Builtin_defs.false_type); Patterns.define n (Patterns.constr Builtin_defs.false_type);
n n
let ops = Hashtbl.create 13 let ops = Hashtbl.create 13
let register_op op arity f = Hashtbl.add ops op (arity,f) let register_op op arity f = Hashtbl.add ops op (arity,f)
let typ_op op = snd (Hashtbl.find ops op) let typ_op op = snd (Hashtbl.find ops op)
......
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