Commit 1d1ed411 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2005-08-29 18:27:33 by afrisch] More localized error on types/patterns...

[r2005-08-29 18:27:33 by afrisch] More localized error on types/patterns (still need to fix for regexps)

Original author: afrisch
Date: 2005-08-29 18:27:33+00:00
parent 82c839d4
open Ident
type err = string -> exn
let deferr s = raise (Patterns.Error s)
type node = {
mutable desc: desc;
mutable smallhash: int; (* Local hash *)
......@@ -14,18 +17,18 @@ open Ident
and desc =
| ILink of node
| IType of Types.descr * int
| IOr of node * node
| IAnd of node * node
| IDiff of node * node
| IOr of node * node * err
| IAnd of node * node * err
| IDiff of node * node * err
| ITimes of node * node
| IXml of node * node
| IArrow of node * node
| IOptional of node
| IRecord of bool * (node * node option) label_map
| IOptional of node * err
| IRecord of bool * (node * node option) label_map * err
| ICapture of id
| IConstant of id * Types.const
| IConcat of node * node
| IMerge of node * node
| IConcat of node * node * err
| IMerge of node * node * err
let concats = ref []
......@@ -41,29 +44,31 @@ open Ident
let mk_delayed () = { node_temp with desc = ILink node_temp }
let mk_type t = mk (IType (t, Types.hash t))
let mk_or n1 n2 = mk (IOr (n1,n2))
let mk_and n1 n2 = mk (IAnd (n1,n2))
let mk_diff n1 n2 = mk (IDiff (n1,n2))
let mk_or ?(err=deferr) n1 n2 = mk (IOr (n1,n2,err))
let mk_and ?(err=deferr) n1 n2 = mk (IAnd (n1,n2,err))
let mk_diff ?(err=deferr) n1 n2 = mk (IDiff (n1,n2,err))
let mk_prod n1 n2 = mk (ITimes (n1,n2))
let mk_xml n1 n2 = mk (IXml (n1,n2))
let mk_arrow n1 n2 = mk (IArrow (n1,n2))
let mk_optional n = mk (IOptional n)
let mk_record n1 n2 = mk (IRecord (n1,n2))
let mk_optional ?(err=deferr) n = mk (IOptional (n,err))
let mk_record ?(err=deferr) n1 n2 = mk (IRecord (n1,n2,err))
let mk_capture n = mk (ICapture n)
let mk_constant n1 n2 = mk (IConstant (n1,n2))
let mk_concat n1 n2 = let n = mk (IConcat (n1,n2)) in concats := n :: !concats; n
let mk_merge n1 n2 = let n = mk (IMerge (n1,n2)) in concats := n :: !concats; n
let mk_concat ?(err=deferr) n1 n2 =
let n = mk (IConcat (n1,n2,err)) in concats := n :: !concats; n
let mk_merge ?(err=deferr) n1 n2 =
let n = mk (IMerge (n1,n2,err)) in concats := n :: !concats; n
let iempty = mk_type Types.empty
let mk_or p1 p2 =
let mk_or ?err p1 p2 =
if p1.desc == iempty.desc then p2
else if p2.desc == iempty.desc then p1
else mk_or p1 p2
else mk_or ?err p1 p2
let mk_and p1 p2 =
let mk_and ?err p1 p2 =
if (p1.desc == iempty.desc) || (p2.desc == iempty.desc) then iempty
else mk_and p1 p2
else mk_and ?err p1 p2
(* Recursive hash-consing *)
......@@ -74,14 +79,14 @@ open Ident
let rec hash f n = match n.desc with
| ILink n -> hash f n
| IType (t,h) -> 1 + 17 * h
| IOr (p1,p2) -> 2 + 17 * f p1 + 257 * f p2
| IAnd (p1,p2) -> 3 + 17 * f p1 + 257 * f p2
| IDiff (p1,p2) -> 4 + 17 * f p1 + 257 * f p2
| IOr (p1,p2,_) -> 2 + 17 * f p1 + 257 * f p2
| IAnd (p1,p2,_) -> 3 + 17 * f p1 + 257 * f p2
| IDiff (p1,p2,_) -> 4 + 17 * f p1 + 257 * f p2
| ITimes (p1,p2) -> 5 + 17 * f p1 + 257 * f p2
| IXml (p1,p2) -> 6 + 17 * f p1 + 257 * f p2
| IArrow (p1,p2) -> 7 + 17 * f p1 + 257 * f p2
| IOptional p -> 8 + 17 * f p
| IRecord (o,r)->9+(if o then 17 else 0)+
| IOptional (p,_) -> 8 + 17 * f p
| IRecord (o,r,_)->9+(if o then 17 else 0)+
257*(LabelMap.hash (hash_field f) r)
| ICapture x -> 10 + 17 * (Id.hash x)
| IConstant (x,c) -> 11 + 17 * (Id.hash x) + 257*(Types.Const.hash c)
......@@ -125,14 +130,14 @@ open Ident
they would be equal *)
else match x.desc,y.desc with
| IType (tx,_), IType (ty,_) when Types.equal tx ty -> link x y
| IOr (x1,x2), IOr (y1,y2)
| IAnd (x1,x2), IAnd (y1,y2)
| IDiff (x1,x2), IDiff (y1,y2)
| IOr (x1,x2,_), IOr (y1,y2,_)
| IAnd (x1,x2,_), IAnd (y1,y2,_)
| IDiff (x1,x2,_), IDiff (y1,y2,_)
| ITimes (x1,x2), ITimes (y1,y2)
| IXml (x1,x2), IXml (y1,y2)
| IArrow (x1,x2), IArrow (y1,y2) -> link x y; unify x1 y1; unify x2 y2
| IOptional x1, IOptional y1 -> link x y; unify x1 y1
| IRecord (xo,xr), IRecord (yo,yr) when xo == yo ->
| IOptional (x1,_), IOptional (y1,_) -> link x y; unify x1 y1
| IRecord (xo,xr,_), IRecord (yo,yr,_) when xo == yo ->
link x y; LabelMap.may_collide unify_field Unify xr yr
| ICapture xv, ICapture yv when Id.equal xv yv -> ()
| IConstant (xv,xc), IConstant (yv,yc) when
......@@ -161,10 +166,10 @@ open Ident
| (x, Some y) -> f x; f y
| (x, None) -> f x
let iter f = function
| IOr (x,y) | IAnd (x,y) | IDiff (x,y)
| IOr (x,y,_) | IAnd (x,y,_) | IDiff (x,y,_)
| ITimes (x,y) | IXml (x,y) | IArrow (x,y) -> f x; f y
| IOptional x -> f x
| IRecord (_,r) -> LabelMap.iter (iter_field f) r
| IOptional (x,_) -> f x
| IRecord (_,r,_) -> LabelMap.iter (iter_field f) r
| _ -> ()
let minimize ((mem,add) as h) =
......@@ -290,21 +295,22 @@ open Ident
| None -> let t = compute_typ n.desc in n.t <- Some t; t
and compute_typ = function
| IType (t,_) -> t
| IOr (s1,s2) -> Types.cup (typ s1) (typ s2)
| IAnd (s1,s2) -> Types.cap (typ s1) (typ s2)
| IDiff (s1,s2) -> Types.diff (typ s1) (typ s2)
| IOr (s1,s2,_) -> Types.cup (typ s1) (typ s2)
| IAnd (s1,s2,_) -> Types.cap (typ s1) (typ s2)
| IDiff (s1,s2,_) -> Types.diff (typ s1) (typ s2)
| ITimes (s1,s2) -> Types.times (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)
| IOptional s -> Types.Record.or_absent (typ s)
| IRecord (o,r) -> Types.record_fields (o, LabelMap.map compute_typ_field r)
| IOptional (s,_) -> Types.Record.or_absent (typ s)
| IRecord (o,r,err) ->
Types.record_fields (o, LabelMap.map (compute_typ_field err) r)
| ILink _ -> assert false
| ICapture _ | IConstant (_,_) -> assert false
| IConcat _ | IMerge _ -> assert false
and compute_typ_field = function
and compute_typ_field err = function
| (s, None) -> typ_node s
| (s, Some _) ->
raise (Patterns.Error "Or-else clauses are not allowed in types")
raise (err "Or-else clauses are not allowed in types")
and typ_node n =
let n = repr n in
......@@ -325,18 +331,22 @@ open Ident
| None -> let p = compute_pat n.desc in n.p <- Some p; p
and compute_pat = function
| IOr (s1,s2) -> Patterns.cup (pat s1) (pat s2)
| IAnd (s1,s2) -> Patterns.cap (pat s1) (pat s2)
| IDiff (s1,s2) when IdSet.is_empty (fv s2) ->
| IOr (s1,s2,err) ->
(try Patterns.cup (pat s1) (pat s2)
with Patterns.Error s -> raise (err s))
| IAnd (s1,s2,err) ->
(try Patterns.cap (pat s1) (pat s2)
with Patterns.Error s -> raise (err s))
| IDiff (s1,s2,_) when IdSet.is_empty (fv s2) ->
let s2 = Types.neg (typ s2) in
Patterns.cap (pat s1) (Patterns.constr s2)
| IDiff _ ->
raise (Patterns.Error "Differences are not allowed in patterns")
| IDiff (_,_,err) ->
raise (err "Differences are not allowed in patterns")
| ITimes (s1,s2) -> Patterns.times (pat_node s1) (pat_node s2)
| IXml (s1,s2) -> Patterns.xml (pat_node s1) (pat_node s2)
| IOptional _ ->
raise (Patterns.Error "Optional fields are not allowed in record patterns")
| IRecord (o,r) ->
| IOptional (_,err) ->
raise (err "Optional fields are not allowed in record patterns")
| IRecord (o,r,err) ->
let pats = ref [] in
let aux l = function
| (s,None) ->
......@@ -346,7 +356,7 @@ open Ident
Types.any_node )
| (s,Some e) ->
if IdSet.is_empty (fv s) then
raise (Patterns.Error "Or-else clauses are not allowed in types")
raise (err "Or-else clauses are not allowed in types")
else
( pats := Patterns.cup
(Patterns.record l (pat_node s))
......@@ -580,7 +590,7 @@ open Ident
let check_wf p =
let rec aux q = if p == q then raise Exit; aux2 q.desc
and aux2 = function
| IOr (q1,q2) | IAnd (q1,q2) | IDiff (q1,q2) -> aux q1; aux q2
| IOr (q1,q2,_) | IAnd (q1,q2,_) | IDiff (q1,q2,_) -> aux q1; aux q2
| ILink q -> aux q
| _ -> ()
in
......@@ -593,18 +603,18 @@ open Ident
let rec elim_concat n =
match n.desc with
| IConcat (a,b) ->
| IConcat (a,b,err) ->
if (n.sid > 0)
then raise (Patterns.Error "Ill-formed concatenation loop");
then raise (err "Ill-formed concatenation loop");
n.sid <- 1;
n.desc <- ILink (elim_conc a b)
| IMerge (a,b) ->
n.desc <- ILink (elim_conc a b err)
| IMerge (a,b,err) ->
if (n.sid > 0)
then raise (Patterns.Error "Ill-formed merge loop");
then raise (err "Ill-formed merge loop");
n.sid <- 1;
n.desc <- ILink (elim_merge a b)
n.desc <- ILink (elim_merge a b err)
| _ -> ()
and elim_merge a b =
and elim_merge a b err =
let get_rec t =
let t = Types.Record.get t in
List.map (fun (l,o,_) ->
......@@ -627,34 +637,34 @@ open Ident
| IType (t1,_), IType (t2,_) ->
if not (Types.subtype t1 Types.Record.any) then
raise
(Patterns.Error
(err
"Left argument of record concatenation is not a record type");
if not (Types.subtype t2 Types.Record.any) then
raise
(Patterns.Error
(err
"Right argument of record concatenation is not a record type");
mk_type (Types.Record.merge t1 t2)
| IOr (a1,a2), _ -> mk_or (elim_merge a1 b) (elim_merge a2 b)
| _, IOr (b1,b2) -> mk_or (elim_merge a b1) (elim_merge a b2)
| IRecord (o1,l1), IRecord (o2,l2) -> merge (o1,l1) (o2,l2)
| IType (t1,_), IRecord (o2,l2) ->
| IOr (a1,a2,_), _ -> mk_or (elim_merge a1 b err) (elim_merge a2 b err)
| _, IOr (b1,b2,_) -> mk_or (elim_merge a b1 err) (elim_merge a b2 err)
| IRecord (o1,l1,_), IRecord (o2,l2,_) -> merge (o1,l1) (o2,l2)
| IType (t1,_), IRecord (o2,l2,_) ->
if not (Types.subtype t1 Types.Record.any) then
raise
(Patterns.Error
(err
"Left argument of record concatenation is not a record type");
List.fold_left (fun accu (o1,l1) ->
mk_or accu (merge (o1,l1) (o2,l2)))
iempty (get_rec t1)
| IRecord (o1,l1), IType (t2,_) ->
| IRecord (o1,l1,_), IType (t2,_) ->
if not (Types.subtype t2 Types.Record.any) then
raise
(Patterns.Error
(err
"Right argument of record concatenation is not a record type");
List.fold_left (fun accu (o2,l2) ->
mk_or accu (merge (o1,l1) (o2,l2)))
iempty (get_rec t2)
| _ -> raise (Patterns.Error "Cannot compute record concatenation")
and elim_conc n q =
| _ -> raise (err "Cannot compute record concatenation")
and elim_conc n q err =
let mem = ref [] in
let rec aux n =
try List.assq n !mem
......@@ -664,19 +674,19 @@ open Ident
let rec aux2 n =
match n.desc with
| ILink n' -> aux2 n'
| IOr (a,b) -> mk_or (aux a) (aux b)
| IOr (a,b,_) -> mk_or (aux a) (aux b)
| ITimes (a,b) -> mk_prod a (aux b)
| IConcat (a,b) -> elim_concat n; aux2 n
| IType (t,_) -> elim_concat_type t q
| _ -> raise (Patterns.Error "Cannot compute concatenation")
| IConcat (a,b,_) -> elim_concat n; aux2 n
| IType (t,_) -> elim_concat_type t q err
| _ -> raise (err "Cannot compute concatenation")
in
r.desc <- ILink (aux2 n);
r
in
aux n
and elim_concat_type t q =
and elim_concat_type t q err =
if not (Types.subtype t Sequence.any) then
raise (Patterns.Error "Left argument of concatenation is not a sequence type");
raise (err "Left argument of concatenation is not a sequence type");
let mem = H.create 17 in
let rec aux t =
try H.find mem t
......
open Ident
type err = string -> exn
type node
val mk_delayed: unit -> node
val link: node -> node -> unit
val mk_type : Types.descr -> node
val mk_or : node -> node -> node
val mk_and: node -> node -> node
val mk_diff: node -> node -> node
val mk_or : ?err:err -> node -> node -> node
val mk_and: ?err:err -> node -> node -> node
val mk_diff: ?err:err -> node -> node -> node
val mk_prod: node -> node -> node
val mk_xml: node -> node -> node
val mk_arrow: node -> node -> node
val mk_optional: node -> node
val mk_record: bool -> (node * node option) label_map -> node
val mk_optional: ?err:err -> node -> node
val mk_record: ?err:err -> bool -> (node * node option) label_map -> node
val mk_constant: id -> Types.const -> node
val mk_capture: id -> node
val mk_concat: node -> node -> node
val mk_merge: node -> node -> node
val mk_concat: ?err:err -> node -> node -> node
val mk_merge: ?err:err -> node -> node -> node
val check_wf: node -> bool
......
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