(WIP) Formalisation de la logique de Why3/API: refonte en cours

examples/in_progress/why3_logic/context.mlw

+
+module Ctx
+  
+  (* Variable contexts. *)
+  
+  use import support.HO
+  
+  type context 'p 'l
+  function c_ldom (context 'p 'l) : 'l -> bool
+  function c_pdom (context 'p 'l) : 'p -> bool
+  function c_ltp (context 'p 'l) : 'l -> 'p
+  function c_ptl (context 'p 'l) : 'p -> 'l
+  axiom context_inv : forall c:context 'p 'l.
+    maps_to c.c_ldom c.c_ltp c.c_pdom /\
+    maps_to c.c_pdom c.c_ptl c.c_ldom /\
+    (forall x. c.c_ldom x -> c.c_ptl (c.c_ltp x) = x) /\
+    (forall x. c.c_pdom x -> c.c_ltp (c.c_ptl x) = x)
+  
+  predicate context_inj (c1:context 'p 'l1) (f:'l1 -> 'l2) (c2:context 'p 'l2) =
+    forall x. c1.c_pdom x -> c2.c_pdom x /\ c2.c_ptl x = f (c1.c_ptl x)
+  
+end
+

examples/in_progress/why3_logic/context/why3session.xml

+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE why3session PUBLIC "-//Why3//proof session v5//EN"
+"http://why3.lri.fr/why3session.dtd">
+<why3session shape_version="4">
+<file name="../context.mlw" expanded="true">
+<theory name="Ctx" sum="d41d8cd98f00b204e9800998ecf8427e" expanded="true">
+</theory>
+</file>
+</why3session>

examples/in_progress/why3_logic/extmap.mlw

+
+module Not_found
+  
+  exception Not_found
+  
+end
+
+module FMap
+  
+  use import support.HO
+  use import support.Finite
+  use import Not_found
+  use import option.Option
+  use mach.peano.Peano as P
+  
+  (* Program representation of a key. *)
+  type key
+  (* Logic representation of a key. The model projection need to be known
+     here to recover the right modelisation as the assocation maps
+     depends only on that part of the key. *)
+  type key_l
+  function k_m key : key_l
+  
+  (* Finite associaton table. *)
+  type t 'a
+  function domain (t 'a) : key_l -> bool
+  function bindings (t 'a) : key_l -> 'a
+  axiom t_inv : forall m:t 'a. finite m.domain
+  
+  (* Immediate implementation of sets on top of fmap. *)
+  type s = t unit
+  
+  val empty () : t 'a
+    ensures { result.domain = none }
+  
+  val is_empty (m:t 'a) : bool
+    ensures { result -> m.domain = none }
+    ensures { forall x. m.domain x -> not result }
+  
+  val mem (x:key) (m:t 'a) : bool
+    ensures { result <-> m.domain (k_m x) }
+  
+  val add (x:key) (b:'a) (m:t 'a) : t 'a
+    ensures { result.domain = update m.domain x.k_m true }
+    ensures { result.bindings = update m.bindings x.k_m b }
+  
+  val singleton (x:key) (b:'a) : t 'a
+    ensures { result.domain = update none x.k_m true }
+    ensures { result.bindings x.k_m = b }
+  
+  val remove (x:key) (m:t 'a) : t 'a
+    ensures { result.domain = update m.domain x.k_m false }
+    ensures { result.bindings = m.bindings }
+  
+  val cardinal (m:t 'a) : P.t
+    ensures { finite m.domain }
+    ensures { result.P.v = cardinal m.domain }
+  
+  val find (x:key) (m:t 'a) : 'a
+    ensures { m.domain x.k_m /\ m.bindings x.k_m = result }
+    raises { Not_found -> not m.domain x.k_m }
+  
+  val set_union (m1 m2:t 'a) : t 'a
+    ensures { forall x. result.domain x <-> m1.domain x \/ m2.domain x }
+    ensures { result.bindings = ho_ite m1.domain m1.bindings m2.bindings }
+  
+  val set_inter (m1 m2:t 'a) : t 'a
+    ensures { forall x. result.domain x <-> m1.domain x /\ m2.domain x }
+    ensures { result.bindings = m1.bindings }
+  
+  val set_diff (m1 m2:t 'a) : t 'a
+    ensures { forall x. result.domain x <-> m1.domain x /\ not m2.domain x }
+    ensures { result.bindings = m1.bindings }
+  
+  val set_submap (m1 m2:t 'a) : bool
+    ensures { result <-> subset m1.domain m2.domain }
+  
+  val set_disjoint (m1 m2:t 'a) : bool
+    ensures { result <-> forall x. not (m1.domain x /\ m2.domain x) }
+  
+  val set_equal (m1 m2:t 'a) : bool
+    ensures { result -> m1.domain = m2.domain }
+    ensures { forall x. m1.domain x <> m2.domain x -> not result }
+  
+  val find_def (d:'a) (x:key) (m:t 'a) : 'a
+    ensures { m.domain x.k_m -> result = m.bindings x.k_m }
+    ensures { not m.domain x.k_m -> result = d }
+  
+  val find_opt (x:key) (m:t 'a) : option 'a
+    ensures { m.domain x.k_m -> result = Some (m.bindings x.k_m) }
+    ensures { not m.domain x.k_m -> result = None }
+    ensures { match result with
+      | None -> not m.domain x.k_m
+      | Some u -> u = m.bindings x.k_m
+      end }
+  
+  val domain (m:t 'a) : s
+    ensures { result.domain = m.domain }
+  
+  val is_num_elt (n:P.t) (m:t 'a) : bool
+    ensures { finite m.domain }
+    ensures { result <-> cardinal m.domain = n.P.v }
+  
+  type enumeration 'a
+  function e_domain (enumeration 'a) : key_l -> bool
+  function e_bindings (enumeration 'a) : key_l -> 'a
+  function e_first (enumeration 'a) : key_l
+  
+  axiom e_inv : forall e:enumeration 'a.
+    not e.e_domain e.e_first -> e.e_domain = none
+  
+  val val_enum (e:enumeration 'a) : option (key,'a)
+    ensures { match result with
+      | None -> e.e_domain = none
+      | Some (k0,v) -> k0.k_m = e.e_first /\ v = e.e_bindings k0.k_m /\
+        e.e_domain k0.k_m
+      end }
+  
+  val start_enum (m:t 'a) : enumeration 'a
+    ensures { result.e_domain = m.domain }
+    ensures { result.e_bindings = m.bindings }
+  
+end
+

examples/in_progress/why3_logic/extmap/why3session.xml

+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE why3session PUBLIC "-//Why3//proof session v5//EN"
+"http://why3.lri.fr/why3session.dtd">
+<why3session shape_version="4">
+<file name="../extmap.mlw" expanded="true">
+<theory name="Not_found" sum="d41d8cd98f00b204e9800998ecf8427e" expanded="true">
+</theory>
+<theory name="FMap" sum="d41d8cd98f00b204e9800998ecf8427e" expanded="true">
+</theory>
+</file>
+</why3session>

examples/in_progress/why3_logic/ident.mlw

+
+(* Very, very abstract views of strings & Why3 locations:
+   they are. *)
+module String
+  type string
+end
+
+module Loc
+  type position
+end
+
+module Label
+  
+  use import String
+  use import Loc
+  
+  type label model { lab_string : string }
+  
+  val lab_equal (l1 l2:label) : bool
+    ensures { result -> l1 = l2 }
+    ensures { l1.lab_string = l2.lab_string -> result }
+  
+  val create_label (s:string) : label
+    ensures { result.lab_string = s }
+  
+  val lab_string (l:label) : string
+    ensures { result = l.lab_string }
+  
+  clone extmap.FMap as Mlab with
+    type key = label,
+    type key_l = string,
+    function k_m = lab_string
+  
+end
+
+module Ident
+  
+  use import int.Int
+  use import String
+  use import Loc
+  use import Label
+  use import option.Option
+  use import list.List
+  use import support.HO
+  
+  (* Abstract name type. *)
+  type ident_name
+  
+  (* Not present in Why3: ghost information allowing to know the
+     identifier class.
+     Justification: Why3 library make use of the fact that the same identifier
+     may be used for only one class of variable: variable symbol,
+     type symbol, function/predicate symbol, proposition symbol, and
+     maybe others. This fact is used to build maps that are the reunion of
+     disjoint maps over those categories. *)
+  type id_class model { id_class_name : ident_name }
+  (* Type of set of all classes build yet, and of snapshots
+     of such classes. Correctness of such specification can be
+     justified via the use of history invariants (this trick is a mere coding
+     of it)
+     Important note about this trick: any mean of countourning the fact
+     that program values of type id_class are build using this interface
+     would break its safety. In practice, this impose limitation about
+     calls to logic function in (ghost) code, (axiomatized default/choice break
+     this property when applied to non-pure logic type such as id_class).
+     In this setup, the safe logic functions calls in (ghost) code are:
+     - any call that instantiate polymorphic variables using
+       pure logic types only (does not interfere with the program world).
+     - any call to a logic function defined on top of safe logic functions
+       (can be lifted to the program world).
+     - projections & constructors (present in the program world).
+   *)
+  type id_class_set model { mutable id_classes : id_class -> bool }
+  type id_class_snapshot model { id_classes_s : id_class -> bool }
+  val ghost idcls : id_class_set
+  val ghost id_class_snapshot () : id_class_snapshot
+    ensures { result.id_classes_s = idcls.id_classes }
+  val ghost id_classes_growth (id0:id_class_snapshot) : unit
+    ensures { subset id0.id_classes_s idcls.id_classes }
+  val ghost id_class_inv (idc:id_class) : unit
+    ensures { idcls.id_classes idc }
+  val ghost fresh_id_class () : id_class
+    writes { idcls }
+    ensures { not (old idcls).id_classes result }
+    ensures { subset (old idcls).id_classes idcls.id_classes }
+    ensures { idcls.id_classes result }
+  
+  (* Projection. *)
+  function idn_string ident_name : string
+  type ident model {
+    id_name : ident_name;
+    id_label : string -> bool;
+    id_loc : option position;
+    (* Not present in Why3 (because ghost): classes to which the identifier
+       belong, ordered. This allow to build hierarchies of disjoint name
+       generators on top of identifiers, while being able to easily recover the
+       disjointness property. *)
+    id_class : list id_class;
+  }
+  
+  function id_string (i:ident) : string = i.id_name.idn_string
+  
+  val id_string (i:ident) : string
+    ensures { result = i.id_string }
+  
+  val id_label (i:ident) : Mlab.s
+    ensures { result.Mlab.domain = i.id_label }
+  
+  val id_loc (i:ident) : option position
+    ensures { result = i.id_loc }
+  
+  type preid = {
+    pre_name : string;
+    pre_label : Mlab.s;
+    pre_loc : option position;
+  }
+  
+  (* Similar mechanism for identifier generation. *)
+  type id_set model { mutable ids : ident_name -> bool }
+  type id_set_snapshot model { ids_s : ident_name -> bool }
+  val ghost ids : id_set
+  val ghost id_set_snapshot () : id_set_snapshot
+    ensures { result.ids_s = ids.ids }
+  val ghost id_set_growth (id0:id_set_snapshot) : unit
+    ensures { subset id0.ids_s ids.ids }
+  val ghost id_inv (i:ident) : unit
+    ensures { ids.ids i.id_name }
+  
+  val id_equal (i1 i2:ident) : bool
+    ensures { result -> i1 = i2 }
+    ensures { i1.id_name = i2.id_name -> result }
+  
+  val id_register (ghost idc:list id_class) (p:preid) : ident
+    writes { ids }
+    ensures { result.id_string = p.pre_name }
+    ensures { result.id_label = p.pre_label.Mlab.domain }
+    ensures { result.id_loc = p.pre_loc }
+    ensures { result.id_class = idc }
+    ensures { not (old ids).ids result.id_name }
+    ensures { subset (old ids).ids ids.ids }
+    ensures { ids.ids result.id_name }
+  
+  clone extmap.FMap as Mid with
+    type key = ident,
+    type key_l = ident_name,
+    function k_m = id_name
+  
+end
+

examples/in_progress/why3_logic/ident/why3session.xml

+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE why3session PUBLIC "-//Why3//proof session v5//EN"
+"http://why3.lri.fr/why3session.dtd">
+<why3session shape_version="4">
+<file name="../ident.mlw" expanded="true">
+<theory name="String" sum="d41d8cd98f00b204e9800998ecf8427e" expanded="true">
+</theory>
+<theory name="Loc" sum="d41d8cd98f00b204e9800998ecf8427e" expanded="true">
+</theory>
+<theory name="Label" sum="d41d8cd98f00b204e9800998ecf8427e" expanded="true">
+</theory>
+<theory name="Ident" sum="d41d8cd98f00b204e9800998ecf8427e" expanded="true">
+</theory>
+</file>
+</why3session>

examples/in_progress/why3_logic/logic_impl/why3session.xml

-<?xml version="1.0" encoding="UTF-8"?>
-<!DOCTYPE why3session PUBLIC "-//Why3//proof session v5//EN"
-"http://why3.lri.fr/why3session.dtd">
-<why3session shape_version="4">
-<prover id="0" name="Alt-Ergo" version="0.99.1" timelimit="5" memlimit="1000"/>
-<file name="../logic_impl.mlw" expanded="true">
-<theory name="Ident" sum="d41d8cd98f00b204e9800998ecf8427e" expanded="true">
-</theory>
-<theory name="Ty" sum="e6b1a0dadb3900c32ea41aeb7e9bfa0c" expanded="true">
- <goal name="WP_parameter sig_world_inv" expl="VC for sig_world_inv" expanded="true">
- <proof prover="0"><result status="valid" time="0.08" steps="102"/></proof>
- </goal>
- <goal name="WP_parameter tyl_inv" expl="VC for tyl_inv">
- <proof prover="0"><result status="valid" time="0.19" steps="300"/></proof>
- </goal>
-</theory>
-<theory name="Term" sum="b19687c0bc7def2d6a9d5eca04977811">
- <goal name="WP_parameter vl_ty_len_nth" expl="VC for vl_ty_len_nth">
- <transf name="split_goal_wp">
-  <goal name="WP_parameter vl_ty_len_nth.1" expl="1. variant decrease">
-  <proof prover="0"><result status="valid" time="0.06" steps="24"/></proof>
-  </goal>
-  <goal name="WP_parameter vl_ty_len_nth.2" expl="2. postcondition">
-  <proof prover="0"><result status="valid" time="0.05" steps="15"/></proof>
-  </goal>
-  <goal name="WP_parameter vl_ty_len_nth.3" expl="3. postcondition">
-  <proof prover="0"><result status="valid" time="0.06" steps="128"/></proof>
-  </goal>
-  <goal name="WP_parameter vl_ty_len_nth.4" expl="4. postcondition">
-  <proof prover="0"><result status="valid" time="0.05" steps="8"/></proof>
-  </goal>
-  <goal name="WP_parameter vl_ty_len_nth.5" expl="5. postcondition">
-  <proof prover="0"><result status="valid" time="0.07" steps="29"/></proof>
-  </goal>
- </transf>
- </goal>
-</theory>
-</file>
-</why3session>

examples/in_progress/why3_logic/logic_theory/why3session.xml

+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE why3session PUBLIC "-//Why3//proof session v5//EN"
+"http://why3.lri.fr/why3session.dtd">
+<why3session shape_version="4">
+<file name="../logic_theory.mlw" expanded="true">
+<theory name="Decl" sum="d41d8cd98f00b204e9800998ecf8427e" expanded="true">
+</theory>
+</file>
+</why3session>

examples/in_progress/why3_logic/signature.mlw

+
+module Sig
+  
+  use import int.Int
+  use import logic_syntax.Defs
+  use import logic_syntax.VarsIn
+  use import logic_typing.Sig as S
+  use import support.HO
+  use import support.Finite
+  
+  (* Global extensible signature.
+     With respect to typing signatures,
+     a new field has been added: the field giving the
+     number of constructors for a type symbol.
+     The reason is that Why3 cache a ls_constr field inside logic symbols
+     that corresponds to the total number of constructors,
+     so it must be known from the signature modelisation.
+   *)
+  type signature model {
+    mutable sig_m : S.signature;
+    mutable tsc_n : ty_symbol -> int;
+  } invariant { sig_wf self.sig_m /\
+      forall tys. self.sig_m.tys_belong tys ->
+        let s = self.sig_m.tys_constr tys in
+        let n0 = self.tsc_n tys in
+        finite s /\ n0 >= cardinal s /\
+        (n0 = cardinal s -> self.sig_m.tys_constr_complete tys) }
+  type signature_s model {
+    sig_m_s : S.signature;
+    tsc_n_s : ty_symbol -> int;
+  } invariant { sig_wf self.sig_m_s /\
+    forall tys. self.sig_m_s.tys_belong tys ->
+      let s = self.sig_m_s.tys_constr tys in
+      let n0 = self.tsc_n_s tys in
+      finite s /\ n0 >= cardinal s /\
+      (n0 = cardinal s -> self.sig_m_s.tys_constr_complete tys) }
+  
+  (* global signature declaration. *)
+  val ghost global_sig : signature
+  val ghost global_sig_snapshot () : signature_s
+    ensures { result.sig_m_s = global_sig.sig_m }
+    ensures { result.tsc_n_s = global_sig.tsc_n }
+  val ghost global_sig_growth (s:signature_s) : unit
+    ensures { let so = s.sig_m_s in let sc = global_sig.sig_m in
+      sig_inclusion so sc /\
+      equalizer (tys_alg so) s.tsc_n_s global_sig.tsc_n }
+  
+  (* Allowed symbols domain, e.g symbol contexts. *)
+  type sym_context
+  function d_tys sym_context : ty_symbol -> bool
+  function d_ls sym_context : lsymbol -> bool
+  function d_constr sym_context : lsymbol -> bool
+  axiom sym_context_inv : forall sc ls. sc.d_constr ls -> sc.d_ls ls
+  
+  predicate sub_sym_context (s1 s2:sym_context) =
+    subset s1.d_tys s2.d_tys /\
+    subset s1.d_ls s2.d_ls /\
+    subset s1.d_constr s2.d_constr
+  
+  predicate sym_ctx_wf (sig:S.signature) (s:sym_context) =
+    subset s.d_tys sig.tys_belong /\
+    subset s.d_ls sig.ls_belong /\
+    subset s.d_constr sig.ls_constr /\
+    (forall ls. s.d_ls ls -> ty_vars_in all s.d_tys (sig.ls_ret ls) /\
+      tyl_vars_in all s.d_tys (sig.ls_args ls))
+  
+  val ghost sym_bounds (sym_c:sym_context) : unit
+    ensures { sym_ctx_wf global_sig.sig_m sym_c }
+  
+end
+

examples/in_progress/why3_logic/signature/why3session.xml

+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE why3session PUBLIC "-//Why3//proof session v5//EN"
+"http://why3.lri.fr/why3session.dtd">
+<why3session shape_version="4">
+<prover id="0" name="Alt-Ergo" version="0.99.1" timelimit="5" memlimit="1000"/>
+<file name="../signature.mlw">
+<theory name="Sig" sum="c089b6032ff37aa2b364017323261821">
+ <goal name="WP_parameter sym_closed_inv" expl="VC for sym_closed_inv">
+ <proof prover="0"><result status="valid" time="0.05" steps="5"/></proof>
+ </goal>
+</theory>
+</file>
+</why3session>

examples/in_progress/why3_logic/ty.mlw

+
+module Tv
+  
+  use import support.HO
+  use import ident.String
+  use import ident.Ident
+  use import ident.Label
+  use import list.List
+  use import option.Option
+  
+  (* Toplevel declaration: ident class of type variables. *)
+  constant tv_id_class_name : ident_name
+  val ghost tv_id_class () : id_class
+    ensures { result.id_class_name = tv_id_class_name }
+  
+  (* Contexts for type variables. Represents the type variables allowed at
+     a given location and the correspondance with their models.
+     TODO: implements a type for general variable contexts, which is
+     basically a bijection between two domains on different types:
+     ident_name & int for type variable context,
+     ident_name & 'a for term variable context. *)
+  type tv_context
+  (*function ctv_m tv_context : context *)
+  function tv_dom tv_context : ident_name -> bool
+  function tv_fun tv_context : ident_name -> int
+  function tv_rfun tv_context : int -> ident_name
+  axiom tv_context_inv : forall ctv id.
+    ctv.tv_dom id -> ctv.tv_rfun (ctv.tv_fun id) = id
+  val ghost tv_bounds (ctv:tv_context) : unit
+    ensures { subset ctv.tv_dom ids.ids }
+  val ghost tv_make_context (dm:ident_name -> bool)
+    (fn:ident_name -> int) (rfn:int -> ident_name) : tv_context
+    requires { forall x. dm x -> rfn (fn x) = x }
+    ensures { result.tv_dom = dm }
+    ensures { result.tv_fun = fn }
+    ensures { result.tv_rfun = rfn }
+  
+  (* Context injection in another. *)
+  predicate tv_ctx_inj (tv1:tv_context) (f:int -> int) (tv2:tv_context) =
+    forall i. tv1.tv_dom i -> tv2.tv_dom i /\ tv2.tv_fun i = f (tv1.tv_fun i)
+  
+  type tvsymbol
+  function tv_name tvsymbol : ident
+  function tv_idn (vty:tvsymbol) : ident_name = vty.tv_name.id_name
+  axiom tv_inv : forall x. exists y z.
+    x.tv_name.id_class = Cons y z /\ y.id_class_name = tv_id_class_name
+    
+  
+  val tv_name (vty:tvsymbol) : ident
+    ensures { result = vty.tv_name }
+  
+  val tv_equal (vty1 vty2:tvsymbol) : bool
+    ensures { vty1.tv_name.id_name = vty2.tv_name.id_name -> result }
+    ensures { result -> vty1 = vty2 }
+  
+  val create_tv_symbol (ghost idc:list id_class) (p:preid) : tvsymbol
+    writes { ids }
+    ensures { result.tv_name.id_string = p.pre_name }
+    ensures { result.tv_name.id_label = p.pre_label.Mlab.domain }
+    ensures { result.tv_name.id_loc = p.pre_loc }
+    ensures { exists y. result.tv_name.id_class = Cons y idc /\
+                        y.id_class_name = tv_id_class_name }
+    ensures { not (old ids).ids result.tv_name.id_name }
+    ensures { subset (old ids).ids ids.ids }
+    ensures { ids.ids result.tv_name.id_name }
+  
+  val tv_of_string (s:string) : tvsymbol
+    writes { ids }
+    ensures { result.tv_name.id_string = s }
+    ensures { result.tv_name.id_label = none }
+    ensures { result.tv_name.id_loc = None }
+    ensures { exists y. result.tv_name.id_class = Cons y Nil /\
+                        y.id_class_name = tv_id_class_name }
+    ensures { subset (old ids).ids ids.ids }
+    ensures { ids.ids result.tv_name.id_name }
+  
+end
+
+module Ty
+  
+  use import logic_syntax.Defs as D
+  use import logic_syntax.Maps
+  use import list.List
+  use import list.Length
+  use import support.HO
+  use import support.HOList
+  use import ident.Ident
+  use import signature.Sig
+  use import Tv
+  
+  
+  constant ts_id_class_name : ident_name
+  axiom ts_id_class_name_distinct : ts_id_class_name <> tv_id_class_name
+  val ghost ts_id_class () : id_class
+    ensures { result.id_class_name = ts_id_class_name }
+  
+  (* Type symbol may be defined or abstract (expanded alias). *)
+  type tysymbol
+  function ts_name tysymbol : ident
+  function ts_arity tysymbol : int
+  function ts_abs tysymbol : bool
+  function ts_m tysymbol : D.ty_symbol
+  function ts_def tysymbol : D.ty
+  axiom tv_inv : forall x. exists y z.
+    x.ts_name.id_class = Cons y z /\ y.id_class_name = ts_id_class_name
+  
+  function ts_idn (tys:tysymbol) : ident_name = tys.ts_name.id_name
+  
+  val ts_name (tys:tysymbol) : ident
+    ensures { result = tys.ts_name }
+  
+  (* Correspondance from type symbols to identifiers.
+     FIXME ? using a logical function imply that all identifiers
+     can be pulled back to a type symbols, e.g that the cardinality
+     of the ident_name type is lower than the cardinality of the
+     type symbol type, which is a priori not evident.
+     (otherwise, type symbol generation simply cannot be implemented)
+     The other technique is to use a growing map, but this is much
+     more convoluted. *)
+  function tys_idn (tys:D.ty_symbol) : ident_name
+  
+  (* TODO: type symbol generation: function from global signature ty_symbols to
+     identifiers & reciprocal. *)
+  
+  (* Context mechanism: a type has sense only in a context. *)
+  type ty
+  
+  (* Type context: allowed type variables/symbols and
+     variable name -> integer correspondance.
+     From the point of view of types, corresponds to a domain and
+     an interpretation. *)
+  type ty_ctx model {
+    cty_tv : tv_context;
+    cty_sym : sym_context;
+    cty_d : ty -> bool;
+    cty_m : ty -> D.ty;
+  }
+  
+  type ty_node =
+    | Tyvar tvsymbol
+    | Tyapp tysymbol (list ty)
+  
+  val ty_var (ghost cty:ty_ctx) (vty:tvsymbol) : ty
+    requires { cty.cty_tv.tv_dom vty.tv_idn }
+    ensures { cty.cty_m result = D.TyVar (cty.cty_tv.tv_fun vty.tv_idn) }
+    ensures { cty.cty_d result }
+  
+  val ty_app (ghost cty:ty_ctx) (tys:tysymbol) (tyl:list ty) : ty
+    requires { for_all cty.cty_d tyl /\ length tyl = tys.ts_arity }
+    requires { if tys.ts_abs
+      then cty.cty_sym.d_tys tys.ts_m
+      else false (* TODO: enable application to defined type symbols. *) }
+    ensures { cty.cty_d result }
+    ensures { if tys.ts_abs
+      then cty.cty_m result = D.TyApp tys.ts_m (map cty.cty_m tyl)
+      else false (* TODO. *) }
+  
+  (* context creation. *)
+  val ghost make_ty_ctx (ctv:tv_context) (cts:sym_context) : ty_ctx
+    ensures { result.cty_tv = ctv /\ result.cty_sym = cts }
+  
+  (* Context injection in another and effect on model. *)
+  val ghost ty_ctx_inj (cty1:ty_ctx) (f:int -> int) (cty2:ty_ctx) : ty_ctx
+    requires { tv_ctx_inj cty1.cty_tv f cty2.cty_tv }
+    requires { sub_sym_context cty1.cty_sym cty2.cty_sym }
+    ensures { subset cty1.cty_d cty2.cty_d }
+    ensures { forall ty. cty1.cty_d ty ->
+      cty2.cty_m ty = ty_map f id (cty1.cty_m ty) }
+  
+  val ghost ty_node (ghost cty:ty_ctx) (ty:ty) : ty_node
+    requires { cty.cty_d ty }
+    returns { Tyvar vty -> cty.cty_m ty = D.TyVar (cty.cty_tv.tv_fun vty.tv_idn)
+      | Tyapp tys tyl -> tys.ts_abs /\
+        cty.cty_m ty = D.TyApp tys.ts_m (map cty.cty_m tyl) /\
+        for_all cty.cty_d tyl }
+  
+end
+

examples/in_progress/why3_logic/ty/why3session.xml

+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE why3session PUBLIC "-//Why3//proof session v5//EN"
+"http://why3.lri.fr/why3session.dtd">