Commit e2d51998 authored by Kim Nguyễn's avatar Kim Nguyễn

Merge branch 'debug-typechecking-issue-27-for-merge'

* debug-typechecking-issue-27-for-merge:
  Remove debugging code.
  Add patricia.cd file from Issue #21
  Check constraints on monomorphic variables at the right place.
  Fix a pretty printing error for ground types (the negative part was not shown due to "worth_complement" being called twice).
  Rework the type variable infrastructure. Remove it from the type structure and have the auxiliary function cache the results as needed.
  Debugging annotations.
parents 924ac464 4eeac845
(* Patricia trees
Chris Okasaki and Andrew Gill's paper Fast Mergeable Integer Maps
http://ittc.ku.edu/~andygill/papers/IntMap98.pdf
*)
type Leaf = <leaf key=Caml_int> 'a
type Branch = <brch pre=Caml_int bit=Caml_int>[ (Leaf|Branch) (Leaf|Branch) ]
type Dict = [] | Branch | Leaf
let lowest_bit (x: Caml_int): Caml_int = Pervasives.land x ((0 - x):?Caml_int)
let branching_bit (p0: Caml_int)(p1: Caml_int): Caml_int = lowest_bit (Pervasives.lxor p0 p1)
let mask (p: Caml_int) (m: Caml_int): Caml_int =
Pervasives.land p (Pervasives.pred m)
let matchPrefix (k: Caml_int)(p: Caml_int)(m: Caml_int): Bool =
mask p m = k
let zero_bit (k: Caml_int)(m: Caml_int): Bool = Pervasives.land k m = 0
let lookup (k: Caml_int)(d: Dict) : ['a?] =
match d with
| [] -> []
| <brch pre=p bit=m>[ t0 t1 ] ->
if not (matchPrefix k p m) then []
else if zero_bit k m then lookup k t0
else lookup k t1
| <leaf key=j> x -> if j=k then [ x ] else []
let join (p0: Caml_int, t0: Dict\[],p1: Caml_int,t1: Dict\[]): Leaf | Branch =
let m = branching_bit p0 p1 in
if zero_bit p0 m then
<brch pre=(mask p0 m) bit=m>[t0 t1]
else
<brch pre=(mask p0 m) bit=m>[t1 t0]
let insert (c: 'a -> 'a -> 'a) (k: Caml_int) (x: 'a) (t: Dict): Leaf|Branch =
let ins (Leaf|Branch -> Leaf|Branch ; [] -> Leaf )
| [] -> <leaf key=k> x
| (<leaf key=j>y)&t ->
if j=k then <leaf key=k>(c x y)
else join (k,<leaf key=k>x,j,t)
| (<brch pre=p bit=m>[ t0 t1 ])&t ->
if matchPrefix k p m then
if zero_bit k m then <brch pre=p bit=m>[ (ins t0) t1 ]
else <brch pre=p bit=m>[ t0 (ins t1) ]
else join (k,<leaf key=k>x,p,t)
in ins t
This diff is collapsed.
......@@ -86,13 +86,13 @@ include Custom.T
module Node : Custom.T
module Pair : Bool.S with type elem = (Node.t * Node.t)
module BoolPair : BoolVar.S with
type s = Pair.t and
module BoolPair : BoolVar.S with
type s = Pair.t and
type elem = Pair.t Var.pairvar
module Rec : Bool.S with type elem = bool * Node.t Ident.label_map
module BoolRec : BoolVar.S with
type s = Rec.t and
type s = Rec.t and
type elem = Rec.t Var.pairvar
type descr = t
......@@ -442,7 +442,7 @@ module Tallying : sig
|S of CS.sigma (** Substitution *)
|A of (symsubst * symsubst) (** Composition si (sj t) *)
(** Cartesian Product of two symbolic substitution sets *)
(** Cartesian Product of two symbolic substitution sets *)
val ( ++ ) : symsubst list -> symsubst list -> symsubst list
(** Evaluation of a substitution *)
......@@ -454,8 +454,8 @@ module Tallying : sig
end
(** Square Subtype relation. [squaresubtype delta s t] .
True if there exists a substitution such that s < t only
(** Square Subtype relation. [squaresubtype delta s t] .
True if there exists a substitution such that s < t only
considering variables that are not in delta *)
val squaresubtype : Var.Set.t -> t -> t -> Tallying.CS.sl
val is_squaresubtype : Var.Set.t -> t -> t -> bool
......@@ -469,4 +469,3 @@ val apply_full : Var.Set.t -> t -> t -> t
val apply_raw : Var.Set.t -> t -> t -> Tallying.CS.sl * t * t * t
val squareapply : Var.Set.t -> t -> t -> (Tallying.CS.sl * t)
module V = struct
type t = { id : string; repr : string }
let dump ppf t =
......
......@@ -30,6 +30,7 @@ module Set : sig
val cardinal : t -> int
val from_list : var list -> t
val fold : ('a -> var -> 'a) -> 'a -> t -> 'a
val choose : t -> var
end
type 'a pairvar = [ `Atm of 'a | var ]
......
......@@ -901,7 +901,7 @@ and type_check' loc env ed constr precise = match ed with
"but the interface of the abstraction is not compatible"
in
let env = match a.fun_name with
| None -> env
| None -> env
| Some f -> enter_value f a.fun_typ env
in
(* update \delta with all variables in t1 -> t2 *)
......@@ -971,9 +971,9 @@ and type_check' loc env ed constr precise = match ed with
(ed,localize loc (flatten (type_map loc env true e b) constr) precise)
| Apply (e1,e2) ->
let t1 = type_check env e1 Types.Arrow.any true in
let t1arrow = Types.Arrow.get t1 in
let t1 = Types.Positive.substitutefree env.delta t1 in
let t1 = type_check env e1 Types.Arrow.any true in
let t1arrow = Types.Arrow.get t1 in
let t1 = Types.Positive.substitutefree env.delta t1 in
(* t [_delta 0 -> 1 *)
begin try
......@@ -991,7 +991,7 @@ and type_check' loc env ed constr precise = match ed with
let (sl,res) =
(* s [_delta dom(t) *)
try Types.squareapply env.delta t1 t2
with Types.Tallying.UnSatConstr _ ->
with Types.Tallying.UnSatConstr msg ->
raise_loc loc (Constraint (t2,dom))
in
res
......
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