Commit 10e54f43 authored by Andrei Paskevich's avatar Andrei Paskevich
Browse files

Merge branch 'autodereference'

Auto-dereferencing references:

    let &x = ... in                     let (x: ref ...) = ... in
    f x;                    ---->       f x.contents;
    x <- ...                            x.contents <- ...

  -- recommended sugar:

    let ref x = ...          ==>        let &x = ref ...

  The & marker adds the typing constraint (x: ref ...)

  Top-level "let/val ref" and "let/val &" are allowed.

  Auto-dereferencing works in logic, but such variables
  cannot be introduced inside logical terms.

Extension to pattern matching:

    match e with                        match e with
    | (x,&y) -> y           ---->       | (x,(y: ref ...)) -> y.contents
    end                                 end

Extension to function parameters and reference passing:

    let incr (&x: ref int) =            let incr (x: ref int) =
      x <- x + 1                          x.contents <- x.contents + 1
                            ---->
    let f () =                          let f () =
      let ref x = 0 in                    let x = ref 0 in
      incr x;                             incr x;
      x                                   x.contents

  -- recommended sugar:

    let incr (ref x: int)    ==>        let incr (&x: ref int)

  The type annotation is not required. Let-functions with such
  formal parameters also prevent the actual argument from
  auto-dereferencing when used in logic. Pure logical symbols
  cannot be declared with such parameters.

  Auto-dereference suppression does not work in the middle of
  a relation chain: in "0 < x :< 17", x will be dereferenced
  even if (:<) expects a ref-parameter on the left.

Caller-side suppression of auto-dereference:

    let f () =                          let f () =
      let ref x = 0 in      ---->         let x = ref 0 in
      g &x                                g x

  The & marker can only be attached to a variable. Works in logic.

Ref-binders and &-binders in variable declarations, patterns,
and function parameters do not require importing ref.Ref.
Any example that does not use references inside data structures
can be rewritten by using ref-binders, without importing ref.Ref.

Explicit use of type symbol "ref", program function "ref",
or field "contents" require importing ref.Ref or why3.Ref.Ref.
Operations (:=) and (!) require importing ref.Ref.

Operation (:=) is fully subsumed by direct assignment (<-).

TODO: find good terminology for documentation. We want to avoid
confusion with regular OCaml-style references.
parents 25315953 67c1adfb
......@@ -5,13 +5,15 @@ prelude "#include <stdint.h>"
prelude "#include <stdio.h>"
prelude "#include <assert.h>"
module ref.Ref
module Ref
syntax type ref "%1"
syntax val ref "%1"
syntax val contents "%1"
end
module ref.Ref
syntax val (!_) "%1"
syntax val (:=) "%1 = %2"
syntax val contents "%1"
end
module mach.int.Unsigned
......
......@@ -48,10 +48,13 @@ theory list.Length
syntax function length "List.length %1"
end
module ref.Ref
module Ref
syntax type ref "%1 ref"
syntax function contents "!%1"
syntax val ref "ref %1"
end
module ref.Ref
syntax val (!_) "!%1"
syntax val (:=) "%1 := %2"
end
......
......@@ -69,6 +69,17 @@ end
(* WhyML *)
module Ref
syntax type ref "%1 ref"
syntax function contents "!%1"
syntax val ref "ref %1"
end
module ref.Ref
syntax val (!_) "!%1"
syntax val (:=) "%1 := %2"
end
module stack.Stack
syntax type t "(%1 Stack.t)"
syntax val create "Stack.create"
......
......@@ -68,10 +68,13 @@ theory list.Combine
syntax function combine "List.combine %1 %2"
end
module ref.Ref
module Ref
syntax type ref "%1 ref"
syntax function contents "!%1"
syntax val ref "ref %1"
end
module ref.Ref
syntax val (!_) "!%1"
syntax val (:=) "%1 := %2"
end
......
......@@ -24,23 +24,23 @@ end
module Simple
use int.Int
use ref.Ref
use ref.Refint
use Square
let isqrt (x:int) : int
requires { x >= 0 }
ensures { isqrt_spec x result }
= let count = ref 0 in
let sum = ref 1 in
while !sum <= x do
invariant { !count >= 0 }
invariant { x >= sqr !count }
invariant { !sum = sqr (!count+1) }
variant { x - !count }
count := !count + 1;
sum := !sum + 2 * !count + 1
= let ref count = 0 in
let ref sum = 1 in
while sum <= x do
invariant { count >= 0 }
invariant { x >= sqr count }
invariant { sum = sqr (count+1) }
variant { x - count }
count += 1;
sum += 2 * count + 1
done;
!count
count
let main ()
ensures { result = 4 }
......@@ -62,32 +62,32 @@ module NewtonMethod
ensures { isqrt_spec x result }
= if x = 0 then 0 else
if x <= 3 then 1 else
let y = ref x in
let z = ref ((1 + x) / 2) in
while !z < !y do
variant { !y }
invariant { !z > 0 }
invariant { !y > 0 }
invariant { !z = div (div x !y + !y) 2 }
invariant { x < sqr (!y + 1) }
invariant { x < sqr (!z + 1) }
y := !z;
z := (x / !z + !z) / 2;
let ref y = x in
let ref z = (1 + x) / 2 in
while z < y do
variant { y }
invariant { z > 0 }
invariant { y > 0 }
invariant { z = div (div x y + y) 2 }
invariant { x < sqr (y + 1) }
invariant { x < sqr (z + 1) }
y <- z;
z <- (x / z + z) / 2;
(* A few hints to prove preservation of the last invariant *)
assert { x < sqr (!z + 1)
by let a = div x !y in
x < a * !y + !y
so a + !y <= 2 * !z + 1
so sqr (a + !y + 1) <= sqr (2 * !z + 2)
so 4 * (sqr (!z + 1) - x)
= sqr (2 * !z + 2) - 4 * x
>= sqr (a + !y + 1) - 4 * x
> sqr (a + !y + 1) - 4 * (a * !y + !y)
= sqr (a + 1 - !y)
assert { x < sqr (z + 1)
by let a = div x y in
x < a * y + y
so a + y <= 2 * z + 1
so sqr (a + y + 1) <= sqr (2 * z + 2)
so 4 * (sqr (z + 1) - x)
= sqr (2 * z + 2) - 4 * x
>= sqr (a + y + 1) - 4 * x
> sqr (a + y + 1) - 4 * (a * y + y)
= sqr (a + 1 - y)
>= 0 }
done;
assert { !y * !y <= div x !y * !y
by !y <= div x !y };
!y
assert { y * y <= div x y * y
by y <= div x y };
y
end
......@@ -25,7 +25,7 @@
(defconst why3-font-lock-keywords-1
(list
`(,(why3-regexp-opt '("invariant" "variant" "diverges" "requires" "ensures" "pure" "returns" "raises" "reads" "writes" "alias" "assert" "assume" "check")) . font-lock-type-face)
`(,(why3-regexp-opt '("use" "clone" "scope" "import" "export" "coinductive" "inductive" "external" "constant" "function" "predicate" "val" "exception" "axiom" "lemma" "goal" "type" "mutable" "abstract" "private" "any" "match" "let" "rec" "in" "if" "then" "else" "begin" "end" "while" "for" "to" "downto" "do" "done" "loop" "absurd" "ghost" "partial" "raise" "return" "break" "continue" "try" "with" "theory" "uses" "module" "fun" "at" "old" "true" "false" "forall" "exists" "label" "by" "so" "meta")) . font-lock-keyword-face)
`(,(why3-regexp-opt '("use" "clone" "scope" "import" "export" "coinductive" "inductive" "external" "constant" "function" "predicate" "val" "exception" "axiom" "lemma" "goal" "type" "mutable" "abstract" "private" "any" "match" "let" "rec" "in" "if" "then" "else" "begin" "end" "while" "for" "to" "downto" "do" "done" "loop" "absurd" "ghost" "partial" "raise" "ref" "return" "break" "continue" "try" "with" "theory" "uses" "module" "fun" "at" "old" "true" "false" "forall" "exists" "label" "by" "so" "meta")) . font-lock-keyword-face)
)
"Minimal highlighting for Why3 mode")
......
......@@ -10,7 +10,7 @@ check,clone,coinductive,constant,continue,diverges,do,done,downto,%
else,end,ensures,exception,exists,export,false,for,forall,fun,%
function,ghost,goal,if,import,in,inductive,invariant,label,lemma,%
let,loop,match,meta,module,mutable,not,old,%
predicate,private,pure,raise,raises,reads,rec,requires,result,return,%
predicate,private,pure,raise,raises,reads,rec,ref,requires,result,return,%
returns,scope,so,then,theory,to,true,try,type,use,val,variant,while,%
with,writes},%
string=[b]",%
......
......@@ -35,6 +35,7 @@ and dvar =
(* In Dreg and Durg, the dity field is a Dapp of the region's type. *)
type dvty = dity list * dity (* A -> B -> C == ([A;B],C) *)
type dref = bool list * bool
let dity_of_dvty (argl,res) =
List.fold_right (fun a d -> Dapp (its_func, [a;d], [])) argl res
......@@ -352,7 +353,7 @@ let specialize_dxs = function
type dpattern = {
dp_pat : pre_pattern;
dp_dity : dity;
dp_vars : dity Mstr.t;
dp_vars : (dity * bool) Mstr.t;
dp_loc : Loc.position option;
}
......@@ -407,7 +408,7 @@ type dexpr = {
}
and dexpr_node =
| DEvar of string * dvty
| DEvar of string * dvty * dref
| DEsym of prog_symbol
| DEconst of Number.constant * dity
| DEapp of dexpr * dexpr
......@@ -429,7 +430,7 @@ and dexpr_node =
| DEoptexn of preid * dity * mask * dexpr
| DEassert of assertion_kind * term later
| DEpure of term later * dity
| DEvar_pure of string * dvty
| DEvar_pure of string * dvty * dref
| DEls_pure of lsymbol * bool
| DEpv_pure of pvsymbol
| DEabsurd
......@@ -457,6 +458,11 @@ let dity_unify_app ls fn (l1: 'a list) (l2: dity list) =
try List.iter2 fn l1 l2 with Invalid_argument _ ->
raise (BadArity (ls, List.length l1))
let dvar_expected_type {pre_loc = loc} dv_dity dity =
try dity_unify dv_dity dity with Exit -> Loc.errorm ?loc
"This variable has type %a,@ but is expected to have type %a"
print_dity dv_dity print_dity dity
let dpat_expected_type {dp_dity = dp_dity; dp_loc = loc} dity =
try dity_unify dp_dity dity with Exit -> Loc.errorm ?loc
"This pattern has type %a,@ but is expected to have type %a"
......@@ -478,7 +484,7 @@ let dexpr_expected_type_weak {de_dvty = dvty; de_loc = loc} dity =
type denv = {
frozen : dity list;
locals : (bool * Stv.t option * dvty) Mstr.t;
locals : (bool * Stv.t option * dvty * dref) Mstr.t;
excpts : dxsymbol Mstr.t
}
......@@ -507,27 +513,29 @@ let free_vars frozen (argl,res) =
| Dapp (_,tl,_) -> List.fold_left add s tl in
List.fold_left add (add Stv.empty res) argl
let denv_add_exn { frozen = fz; locals = ls; excpts = xs } id dity =
let denv_add_exn {frozen = fz; locals = ls; excpts = xs} id dity =
let xs = Mstr.add id.pre_name (DElexn (id.pre_name, dity)) xs in
{ frozen = freeze_dvty fz ([], dity); locals = ls; excpts = xs }
let denv_add_mono { frozen = fz; locals = ls; excpts = xs } id dvty =
let ls = Mstr.add id.pre_name (false, None, dvty) ls in
let denv_add_mono {frozen = fz; locals = ls; excpts = xs} id dvty dref =
let ls = Mstr.add id.pre_name (false, None, dvty, dref) ls in
{ frozen = freeze_dvty fz dvty; locals = ls; excpts = xs }
let denv_add_poly { frozen = fz; locals = ls; excpts = xs } id dvty =
let ls = Mstr.add id.pre_name (false, Some (free_vars fz dvty), dvty) ls in
let denv_add_poly {frozen = fz; locals = ls; excpts = xs} id dvty dref =
let fvs = free_vars fz dvty in
let ls = Mstr.add id.pre_name (false, Some fvs, dvty, dref) ls in
{ frozen = fz; locals = ls; excpts = xs }
let denv_add_rec_mono { frozen = fz; locals = ls; excpts = xs } id dvty =
let ls = Mstr.add id.pre_name (false, Some Stv.empty, dvty) ls in
let denv_add_rec_mono {frozen = fz; locals = ls; excpts = xs} id dvty dref =
let ls = Mstr.add id.pre_name (false, Some Stv.empty, dvty, dref) ls in
{ frozen = freeze_dvty fz dvty; locals = ls; excpts = xs }
let denv_add_rec_poly { frozen = fz; locals = ls; excpts = xs } fz0 id dvty =
let ls = Mstr.add id.pre_name (false, Some (free_vars fz0 dvty), dvty) ls in
let denv_add_rec_poly {frozen = fz; locals = ls; excpts = xs} fz0 id dvty dref =
let fvs = free_vars fz0 dvty in
let ls = Mstr.add id.pre_name (false, Some fvs, dvty, dref) ls in
{ frozen = fz; locals = ls; excpts = xs }
let denv_add_rec denv fz0 id ((argl,res) as dvty) =
let denv_add_rec denv fz0 id ((argl,res) as dvty) dref =
let rec is_explicit = function
| Dvar {contents = (Dval d|Dpur d|Dsim (d,_)|Dreg (d,_))}
| Durg (d,_) -> is_explicit d
......@@ -535,40 +543,86 @@ let denv_add_rec denv fz0 id ((argl,res) as dvty) =
| Dutv _ -> true
| Dapp (_,tl,_) -> List.for_all is_explicit tl in
if List.for_all is_explicit argl && is_explicit res
then denv_add_rec_poly denv fz0 id dvty
else denv_add_rec_mono denv id dvty
then denv_add_rec_poly denv fz0 id dvty dref
else denv_add_rec_mono denv id dvty dref
let attr_dref attrs = Sattr.mem Pmodule.ref_attr attrs
let denv_add_var denv id dity = denv_add_mono denv id ([], dity)
let bl_dref bl =
let check = function
| Some id,_,_ -> attr_dref id.pre_attrs
| _ -> false in
List.map check bl
let bl_type bl = List.map (fun (_,_,t) -> t) bl
let pv_dref pv = attr_dref pv.pv_vs.vs_name.id_attrs
let id_nref {pre_loc = loc; pre_attrs = attrs} =
if attr_dref attrs then Loc.errorm ?loc
"reference markers are only admitted over program variables";
false
let id_dref id dity =
if attr_dref id.pre_attrs then begin
let dity_ref = dity_reg (Dapp (its_ref, [dity_fresh ()], [])) in
dvar_expected_type id dity dity_ref;
true
end else
false
let argl_dref ({de_dvty = argl,_} as de) =
let rec cut dr acc = match dr, acc with
| dr, [] -> assert (List.length dr = List.length argl); dr
| _::dr, _::acc -> cut dr acc
| _, _ -> List.map Util.ffalse argl in
let rec deapp acc de = match de.de_node with
| DEvar (_,_,(dr,_)) (* no DEvar_pure|DEls_pure *) -> cut dr acc
| DEsym (RS rs) -> cut (List.map pv_dref rs.rs_cty.cty_args) acc
| DEfun (bl,_,_,_,_) | DEany (bl,_,_,_) -> cut (bl_dref bl) acc
| DEapp (de,d) -> deapp (d::acc) de
| DEuloc (de,_) | DEattr (de,_) | DEcast (de,_)
| DElet (_,de) | DErec (_,de) | DElabel (_,de)
| DEexn (_,_,_,de) | DEoptexn (_,_,_,de)
| DEghost de -> deapp acc de
| _ -> List.map Util.ffalse argl in
deapp [] de
let denv_add_var denv id dity =
denv_add_mono denv id ([], dity) ([], id_dref id dity)
let denv_add_for_index denv id dvty =
let dvty = [], dity_of_dvty dvty in
let dref = [], id_dref id (snd dvty) in
let { frozen = fz; locals = ls; excpts = xs } = denv in
let ls = Mstr.add id.pre_name (true, None, dvty) ls in
let ls = Mstr.add id.pre_name (true, None, dvty, dref) ls in
{ frozen = freeze_dvty fz dvty; locals = ls; excpts = xs }
let denv_add_let denv (id,_,_,({de_dvty = dvty} as de)) =
if fst dvty = [] then denv_add_mono denv id dvty else
let denv_add_let denv (id,_,_,({de_dvty = (argl,res as dvty)} as de)) =
let dref = if argl = [] then [], id_dref id res
else argl_dref de, id_nref id in
if argl = [] then denv_add_mono denv id dvty dref else
let rec is_value de = match de.de_node with
| DEghost de | DEuloc (de,_) | DEattr (de,_) -> is_value de
| DEvar _ | DEsym _ | DEls_pure _ | DEfun _ | DEany _ -> true
| _ -> false in
if is_value de
then denv_add_poly denv id dvty
else denv_add_mono denv id dvty
if is_value de then denv_add_poly denv id dvty dref
else denv_add_mono denv id dvty dref
let denv_add_args { frozen = fz; locals = ls; excpts = xs } bl =
let denv_add_args {frozen = fz; locals = ls; excpts = xs} bl =
let l = List.fold_left (fun l (_,_,t) -> t::l) fz bl in
let add s (id,_,t) = match id with
| Some {pre_name = n} ->
Mstr.add_new (Dterm.DuplicateVar n) n (false, None, ([],t)) s
| Some ({pre_name = n} as id) ->
let dvty = [], t and dref = [], id_dref id t in
Mstr.add_new (Dterm.DuplicateVar n) n (false, None, dvty, dref) s
| None -> s in
let s = List.fold_left add Mstr.empty bl in
{ frozen = l; locals = Mstr.set_union s ls; excpts = xs }
let denv_add_pat { frozen = fz; locals = ls; excpts = xs } dp dity =
let denv_add_pat {frozen = fz; locals = ls; excpts = xs} dp dity =
dpat_expected_type dp dity;
let l = Mstr.fold (fun _ t l -> t::l) dp.dp_vars fz in
let s = Mstr.map (fun t -> false, None, ([], t)) dp.dp_vars in
let l = Mstr.fold (fun _ (t,_) l -> t::l) dp.dp_vars fz in
let s = Mstr.map (fun (t,d) -> false, None, ([],t), ([],d)) dp.dp_vars in
{ frozen = l; locals = Mstr.set_union s ls; excpts = xs }
let denv_add_expr_pat denv dp de =
......@@ -578,8 +632,8 @@ let denv_add_exn_pat denv dp dxs =
denv_add_pat denv dp (specialize_dxs dxs)
let mk_node n = function
| _, Some tvs, dvty -> DEvar (n, specialize_scheme tvs dvty)
| _, None, dvty -> DEvar (n, dvty)
| _, Some tvs, dvty, dref -> DEvar (n, specialize_scheme tvs dvty, dref)
| _, None, dvty, dref -> DEvar (n, dvty, dref)
let denv_get denv n =
mk_node n (Mstr.find_exn (Dterm.UnboundVar n) n denv.locals)
......@@ -588,8 +642,8 @@ let denv_get_opt denv n =
Opt.map (mk_node n) (Mstr.find_opt n denv.locals)
let mk_node_pure n = function
| _, Some tvs, dvty -> DEvar_pure (n, specialize_scheme tvs dvty)
| _, None, dvty -> DEvar_pure (n, dvty)
| _, Some tvs, dvty, dref -> DEvar_pure (n, specialize_scheme tvs dvty, dref)
| _, None, dvty, dref -> DEvar_pure (n, dvty, dref)
let denv_get_pure denv n =
mk_node_pure n (Mstr.find_exn (Dterm.UnboundVar n) n denv.locals)
......@@ -614,9 +668,13 @@ let denv_pure denv get_dty =
let f = Dterm.dty_fresh () in Htv.add ht v (f,d); f end
| Dapp (s,dl,_) -> Dterm.dty_app s.its_ts (List.map fold dl)
| Dutv v -> Dterm.dty_var v in
let add n (idx, _, dvty) =
let add n (idx, _, dvty, dref) =
let dity = if idx then dity_int else dity_of_dvty dvty in
Dterm.DTvar (n, fold dity) in
let dt = Dterm.DTvar (n, fold dity) in
if dref = ([], true) then
let dt = Dterm.dterm Coercion.empty dt in
Dterm.DTapp (ls_ref_proj, [dt])
else dt in
let dty = get_dty (Mstr.mapi add denv.locals) in
Htv.iter (fun v (f,_) ->
try Dterm.dty_match f (ty_var v) with Exit -> ()) ht;
......@@ -633,15 +691,14 @@ type pre_fun_defn = preid * ghost * rs_kind * dbinder list *
exception DupId of preid
let drec_defn denv0 prel =
let drec_defn ({frozen = frz} as denv0) prel =
if prel = [] then invalid_arg "Dexpr.drec_defn: empty function list";
let add s (id,_,_,_,_,_,_) = Sstr.add_new (DupId id) id.pre_name s in
let _ = try List.fold_left add Sstr.empty prel with DupId id ->
Loc.errorm ?loc:id.pre_loc "duplicate function name %s" id.pre_name in
let add denv (id,_,_,bl,res,_,_) =
if bl = [] then invalid_arg "Dexpr.drec_defn: empty argument list";
let argl = List.map (fun (_,_,t) -> t) bl in
denv_add_rec denv denv0.frozen id (argl,res) in
denv_add_rec denv frz id (bl_type bl, res) (bl_dref bl, id_nref id) in
let denv1 = List.fold_left add denv0 prel in
let parse (id,gh,pk,bl,res,msk,pre) =
let dsp, dvl, de = pre denv1 in
......@@ -649,16 +706,14 @@ let drec_defn denv0 prel =
(id,gh,pk,bl,res,msk,dsp,dvl,de) in
let fdl = List.map parse prel in
let add denv (id,_,_,bl,res,_,_,_,_) =
(* just in case we linked some polymorphic type var to the outer context *)
let check tv = if is_frozen denv0.frozen tv then Loc.errorm ?loc:id.pre_loc
(* in case we linked some polymorphic type var to the outer context *)
let check tv = if is_frozen frz tv then Loc.errorm ?loc:id.pre_loc
"This function is expected to be polymorphic in type variable %a"
Pretty.print_tv tv in
begin match Mstr.find_opt id.pre_name denv1.locals with
| Some (_, Some tvs, _) -> Stv.iter check tvs
| Some (_, None, _) | None -> assert false
end;
let argl = List.map (fun (_,_,t) -> t) bl in
denv_add_poly denv id (argl, res) in
| Some (_, Some tvs, _, _) -> Stv.iter check tvs
| Some (_, None, _, _) | None -> assert false end;
denv_add_poly denv id (bl_type bl, res) (bl_dref bl, false) in
List.fold_left add denv0 fdl, { fds = fdl }
(** Constructors *)
......@@ -671,7 +726,8 @@ let dpattern ?loc node =
mk_dpat PPwild (dity_fresh ()) Mstr.empty
| DPvar (id,gh) ->
let dity = dity_fresh () in
mk_dpat (PPvar (id,gh)) dity (Mstr.singleton id.pre_name dity)
let vars = Mstr.singleton id.pre_name (dity, id_dref id dity) in
mk_dpat (PPvar (id,gh)) dity vars
| DPapp ({rs_logic = RLls ls} as rs, dpl) when ls.ls_constr > 0 ->
let argl, res = specialize_rs rs in
dity_unify_app ls dpat_expected_type dpl argl;
......@@ -684,15 +740,19 @@ let dpattern ?loc node =
raise (ConstructorExpected rs);
| DPor (dp1,dp2) ->
dpat_expected_type dp2 dp1.dp_dity;
let join n dity1 dity2 = try dity_unify dity1 dity2; Some dity1
let join n (dity1,dref1) (dity2,dref2) =
if dref1 <> dref2 then Loc.errorm ?loc
"Variable %s is used with different ref statuses" n;
try dity_unify dity1 dity2; Some (dity1,dref1)
with Exit -> Loc.errorm ?loc
"Variable %s has type %a,@ but is expected to have type %a"
n print_dity dity1 print_dity dity2 in
let vars = Mstr.union join dp1.dp_vars dp2.dp_vars in
mk_dpat (PPor (dp1.dp_pat, dp2.dp_pat)) dp1.dp_dity vars
| DPas (dp, ({pre_name = n} as id), gh) ->
let exn = Dterm.DuplicateVar n in
let { dp_pat = pat; dp_dity = dity; dp_vars = vars } = dp in
let vars = Mstr.add_new (Dterm.DuplicateVar n) n dity vars in
let vars = Mstr.add_new exn n (dity, id_dref id dity) vars in
mk_dpat (PPas (pat, id, gh)) dity vars
| DPcast (dp, dity) ->
dpat_expected_type dp dity;
......@@ -700,11 +760,27 @@ let dpattern ?loc node =
in
Loc.try1 ?loc dpat node
let to_deref = function
| DEvar (_,_,([],deref))
| DEvar_pure (_,_,([],deref)) -> deref
| DEsym (PV pv)
| DEpv_pure pv -> pv_dref pv
| _ -> false
let rec undereference de = match de.de_node with
| DEuloc (de,l) -> { de with de_node = DEuloc (undereference de, l) }
| DEattr (de,a) -> { de with de_node = DEattr (undereference de, a) }
| DEcast (de,_) -> undereference de (* already unified *)
| DEapp ({de_node = DEsym (RS rs)}, de)
when rs_equal rs rs_ref_proj
&& to_deref de.de_node -> de
| _ -> raise Not_found
let dexpr ?loc node =
let get_dvty = function
| DEvar (_,dvty) ->
| DEvar (_,dvty,_) ->
dvty
| DEvar_pure (_,dvty) ->
| DEvar_pure (_,dvty,_) ->
let dt = dity_fresh () in
dity_unify_asym dt (dity_of_dvty dvty);
[], dt
......@@ -747,9 +823,9 @@ let dexpr ?loc node =
[], r
| DEfun (bl,res,_,_,de) ->
dexpr_expected_type de res;
List.map (fun (_,_,t) -> t) bl, res
bl_type bl, res
| DEany (bl,res,_,_) ->
List.map (fun (_,_,t) -> t) bl, res
bl_type bl, res
| DElet (_,de)
| DErec (_,de) ->
de.de_dvty
......@@ -818,6 +894,26 @@ let dexpr ?loc node =
| DEuloc (de,_)
| DEattr (de,_) ->
de.de_dvty in
(* suppress dereference if needed *)
let node = match node with
| DEapp (e,d) ->
begin try
let r = undereference d in
match argl_dref e with
| true::_ -> DEapp (e,r)
| _ -> node
with Not_found -> node end
| _ -> node in
(* dereference if needed *)
let node = if not (to_deref node) then node else
let de = { de_node = node;
de_dvty = get_dvty node;
de_loc = loc } in
let dr = { de_node = DEsym (RS rs_ref_proj);
de_dvty = specialize_rs rs_ref_proj;
de_loc = loc } in
DEapp (dr, de) in
(* infer types *)
let dvty = Loc.try1 ?loc get_dvty node in
{ de_node = node; de_dvty = dvty; de_loc = loc }
......@@ -1275,7 +1371,7 @@ and try_cexp uloc env ({de_dvty = argl,res} as de0) lpl =
let ld, s = let_sym id ~ghost:(env.ghs || env.lgh) c in
c_app s (LD (LS ld) :: lpl) in
match de0.de_node with
| DEvar (n,_) -> c_app (get_rs env n) lpl
| DEvar (n,_,_) -> c_app (get_rs env n) lpl
| DEsym (RS rs) -> c_app rs lpl
| DEsym (OO ss) -> c_oop ss lpl
| DEls_pure (ls,ugh) -> c_pur ugh ls lpl
......@@ -1321,9 +1417,9 @@ and try_cexp uloc env ({de_dvty = argl,res} as de0) lpl =
and try_expr uloc env ({de_dvty = argl,res} as de0) =
match de0.de_node with
| DEvar (n,_) when argl = [] ->
| DEvar (n,_,_) when argl = [] ->
e_var (get_pv env n)
| DEvar_pure (n,_) ->
| DEvar_pure (n,_,_) ->
e_pure (t_var (get_pv env n).pv_vs)
| DEsym (PV v) ->
e_var v
......
......@@ -30,13 +30,14 @@ val dity_bool : dity
val dity_unit : dity
type dvty = dity list * dity (* A -> B -> C == ([A;B],C) *)
type dref = bool list * bool
(** Patterns *)
type dpattern = private {
dp_pat : pre_pattern;
dp_dity : dity;
dp_vars : dity Mstr.t;
dp_vars : (dity * bool) Mstr.t;
dp_loc : Loc.position option;
}
......@@ -101,7 +102,7 @@ type dexpr = private {
}
and dexpr_node =