module Denv extrait de Typing

Makefile.in

@@ -124,7 +124,7 @@ CORE_CMO := $(addprefix src/core/,$(CORE_CMO))
 UTIL_CMO := pp.cmo loc.cmo util.cmo hashcons.cmo sysutil.cmo
 UTIL_CMO := $(addprefix src/util/,$(UTIL_CMO))
 
-PARSER_CMO := parser.cmo lexer.cmo typing.cmo 
+PARSER_CMO := parser.cmo lexer.cmo denv.cmo typing.cmo 
 PARSER_CMO := $(addprefix src/parser/,$(PARSER_CMO))
 
 TRANSFORM_CMO := simplify_recursive_definition.cmo inlining.cmo\
@@ -159,7 +159,7 @@ bin/top: $(CMO)
 
 test: bin/why.byte
 	mkdir -p output_why3
-	ocamlrun -bt bin/why.byte --debug -I lib/prelude/ --driver lib/drivers/why3.drv \
+	ocamlrun -bt bin/why.byte -I lib/prelude/ --driver lib/drivers/why3.drv \
 	--output-dir output_why3 src/test.why
 	bin/why.byte --driver lib/drivers/alt_ergo.drv -I lib/prelude/ \
 	--output-file - --goal Test.G src/test.why --timeout 3

src/main.ml

@@ -120,6 +120,8 @@ let rec report fmt = function
       fprintf fmt "%a%a" Loc.report_position loc report e
   | Parsing.Parse_error ->
       fprintf fmt "syntax error"
+  | Denv.Error e ->
+      Denv.report fmt e
   | Typing.Error e ->
       Typing.report fmt e
   | UnknownIdent i ->

src/parser/denv.ml

+
+open Format
+open Pp
+open Util
+open Ptree
+open Ident
+open Ty
+open Term
+open Theory
+
+type error = 
+  | UnboundNamespace of string
+  | UnboundType of string
+  | UnboundSymbol of string
+  | AnyMessage of string
+  | TypeArity of qualid * int * int
+
+exception Error of error
+
+let error ?loc e = match loc with
+  | None -> raise (Error e)
+  | Some loc -> raise (Loc.Located (loc, Error e))
+
+let errorm ?loc f =
+  let buf = Buffer.create 512 in
+  let fmt = Format.formatter_of_buffer buf in
+  Format.kfprintf 
+    (fun _ -> 
+       Format.pp_print_flush fmt ();
+       let s = Buffer.contents buf in
+       Buffer.clear buf;
+       error ?loc (AnyMessage s))
+    fmt f
+
+let rec print_qualid fmt = function
+  | Qident s -> fprintf fmt "%s" s.id
+  | Qdot (m, s) -> fprintf fmt "%a.%s" print_qualid m s.id
+
+let report fmt = function
+  | UnboundNamespace s ->
+      fprintf fmt "unbound namespace %s" s
+  | UnboundType s ->
+       fprintf fmt "Unbound type '%s'" s
+  | UnboundSymbol s ->
+       fprintf fmt "Unbound symbol '%s'" s
+  | AnyMessage s ->
+      fprintf fmt "%s" s
+  | TypeArity (id, a, n) ->
+      fprintf fmt "@[The type %a expects %d argument(s),@ " print_qualid id a;
+      fprintf fmt "but is applied to %d argument(s)@]" n
+
+
+(** types with destructive type variables *)
+
+type dty =
+  | Tyvar of type_var
+  | Tyapp of tysymbol * dty list
+      
+and type_var = { 
+  tag : int; 
+  user : bool;
+  tvsymbol : tvsymbol;
+  mutable type_val : dty option;
+  type_var_loc : loc option;
+}
+
+let rec print_dty fmt = function
+  | Tyvar { type_val = Some t } ->
+      print_dty fmt t
+  | Tyvar { type_val = None; tvsymbol = v } ->
+      fprintf fmt "'%s" v.tv_name.id_short
+  | Tyapp (s, []) ->
+      fprintf fmt "%s" s.ts_name.id_short
+  | Tyapp (s, [t]) -> 
+      fprintf fmt "%a %s" print_dty t s.ts_name.id_short
+  | Tyapp (s, l) -> 
+      fprintf fmt "(%a) %s" 
+	(print_list comma print_dty) l s.ts_name.id_short
+
+let create_ty_decl_var =
+  let t = ref 0 in
+  fun ?loc ~user tv -> 
+    incr t; 
+    { tag = !t; user = user; tvsymbol = tv; type_val = None;
+      type_var_loc = loc }
+
+let rec occurs v = function
+  | Tyvar { type_val = Some t } -> occurs v t
+  | Tyvar { tag = t; type_val = None } -> v.tag = t
+  | Tyapp (_, l) -> List.exists (occurs v) l
+
+(* destructive type unification *)
+let rec unify t1 t2 = match t1, t2 with
+  | Tyvar { type_val = Some t1 }, _ ->
+      unify t1 t2
+  | _, Tyvar { type_val = Some t2 } ->
+      unify t1 t2
+  | Tyvar v1, Tyvar v2 when v1.tag = v2.tag ->
+      true
+	(* instantiable variables *)
+  | Tyvar ({user=false} as v), t
+  | t, Tyvar ({user=false} as v) ->
+      not (occurs v t) && (v.type_val <- Some t; true)
+	(* recursive types *)
+  | Tyapp (s1, l1), Tyapp (s2, l2) ->
+      s1 == s2 && List.length l1 = List.length l2 &&
+	  List.for_all2 unify l1 l2
+  | Tyapp _, _ | _, Tyapp _ ->
+      false
+	(* other cases *)
+  | Tyvar {user=true; tag=t1}, Tyvar {user=true; tag=t2} -> 
+      t1 = t2
+
+(* intermediate types -> types *)
+let rec ty_of_dty = function
+  | Tyvar { type_val = Some t } ->
+      ty_of_dty t
+  | Tyvar { type_val = None; user = false; type_var_loc = loc } ->
+      errorm ?loc "undefined type variable"
+  | Tyvar { tvsymbol = tv } ->
+      Ty.ty_var tv
+  | Tyapp (s, tl) ->
+      Ty.ty_app s (List.map ty_of_dty tl)
+
+
+(** Destructive typing environment, that is
+    environment + local variables.
+    It is only local to this module and created with [create_denv] below. *)
+
+type denv = { 
+  th : theory_uc; (* the theory under construction *)
+  utyvars : (string, type_var) Hashtbl.t; (* user type variables *)
+  dvars : dty Mstr.t; (* local variables, to be bound later *)
+}
+
+let create_denv th = { 
+  th = th; 
+  utyvars = Hashtbl.create 17; 
+  dvars = Mstr.empty;
+}
+
+let find_user_type_var x env =
+  try
+    Hashtbl.find env.utyvars x
+  with Not_found ->
+    (* TODO: shouldn't we localize this ident? *)
+    let v = create_tvsymbol (id_fresh x) in
+    let v = create_ty_decl_var ~user:true v in
+    Hashtbl.add env.utyvars x v;
+    v
+ 
+(* Specialize *)
+
+let find_type_var ~loc env tv =
+  try
+    Htv.find env tv
+  with Not_found ->
+    let v = create_ty_decl_var ~loc ~user:false tv in
+    Htv.add env tv v;
+    v
+ 
+let rec specialize ~loc env t = match t.ty_node with
+  | Ty.Tyvar tv -> 
+      Tyvar (find_type_var ~loc env tv)
+  | Ty.Tyapp (s, tl) ->
+      Tyapp (s, List.map (specialize ~loc env) tl)
+
+(** generic find function using a path *)
+
+let find_local_namespace {id=x; id_loc=loc} ns = 
+  try Mnm.find x ns.ns_ns
+  with Not_found -> error ~loc (UnboundNamespace x)
+
+let rec find_namespace q ns = match q with
+  | Qident t -> find_local_namespace t ns
+  | Qdot (q, t) -> let ns = find_namespace q ns in find_local_namespace t ns
+
+let rec find f q ns = match q with
+  | Qident x -> f x ns
+  | Qdot (m, x) -> let ns = find_namespace m ns in f x ns
+
+(** specific find functions using a path *)
+
+let find_local_tysymbol {id=x; id_loc=loc} ns = 
+  try Mnm.find x ns.ns_ts
+  with Not_found -> error ~loc (UnboundType x)
+
+let find_tysymbol_ns p ns =
+  find find_local_tysymbol p ns
+
+let find_tysymbol p th = 
+  find_tysymbol_ns p (get_namespace th)
+
+let find_lsymbol {id=x; id_loc=loc} ns = 
+  try Mnm.find x ns.ns_ls
+  with Not_found -> error ~loc (UnboundSymbol x)
+
+let find_lsymbol_ns p ns = 
+  find find_lsymbol p ns
+
+let find_lsymbol p th = 
+  find_lsymbol_ns p (get_namespace th)
+
+let find_prop {id=x; id_loc=loc} ns = 
+  try Mnm.find x ns.ns_pr
+  with Not_found -> errorm ~loc "unbound formula %s" x
+
+let find_prop_ns p ns =
+  find find_prop p ns
+
+let find_prop p th =
+  find_prop_ns p (get_namespace th)
+
+(** specialize functions *)
+
+let specialize_tysymbol ~loc x env =
+  let s = find_tysymbol x env.th in
+  let env = Htv.create 17 in
+  s, List.map (find_type_var ~loc env) s.ts_args
+	
+let specialize_lsymbol ~loc s =
+  let tl = s.ls_args in
+  let t = s.ls_value in
+  let env = Htv.create 17 in
+  s, List.map (specialize ~loc env) tl, option_map (specialize ~loc env) t
+
+(* parsed types -> intermediate types *)
+
+let rec qloc = function
+  | Qident x -> x.id_loc
+  | Qdot (m, x) -> Loc.join (qloc m) x.id_loc
+
+let rec type_inst s ty = match ty.ty_node with
+  | Ty.Tyvar n -> Mtv.find n s
+  | Ty.Tyapp (ts, tyl) -> Tyapp (ts, List.map (type_inst s) tyl)
+
+let rec dty env = function
+  | PPTtyvar {id=x} -> 
+      Tyvar (find_user_type_var x env)
+  | PPTtyapp (p, x) ->
+      let loc = qloc x in
+      let ts, tv = specialize_tysymbol ~loc x env in
+      let np = List.length p in
+      let a = List.length tv in
+      if np <> a then error ~loc (TypeArity (x, a, np));
+      let tyl = List.map (dty env) p in
+      match ts.ts_def with
+	| None -> 
+	    Tyapp (ts, tyl)
+	| Some ty -> 
+	    let add m v t = Mtv.add v t m in
+            let s = List.fold_left2 add Mtv.empty ts.ts_args tyl in
+	    type_inst s ty
+

src/parser/denv.mli

+
+open Util
+open Ty
+open Term
+open Theory
+
+(** Destructive unification *)
+
+type type_var
+
+type dty = 
+  | Tyvar of type_var
+  | Tyapp of tysymbol * dty list
+
+val create_ty_decl_var : ?loc:Ptree.loc -> user:bool -> tvsymbol -> type_var
+
+val unify : dty -> dty -> bool
+
+val print_dty : Format.formatter -> dty -> unit
+
+
+(** Destructive environments *)
+
+type denv = { 
+  th : theory_uc; (* the theory under construction *)
+  utyvars : (string, type_var) Hashtbl.t; (* user type variables *)
+  dvars : dty Mstr.t; (* local variables, to be bound later *)
+}
+
+val create_denv : theory_uc -> denv
+
+val dty : denv -> Ptree.pty -> dty
+
+val ty_of_dty : dty -> ty
+
+
+(** Lookup *)
+
+val find_tysymbol_ns : Ptree.qualid -> namespace -> tysymbol
+val find_lsymbol_ns : Ptree.qualid -> namespace -> lsymbol
+val find_prop_ns : Ptree.qualid -> namespace -> Decl.prop
+
+val find_tysymbol : Ptree.qualid -> theory_uc -> tysymbol
+val find_lsymbol :  Ptree.qualid -> theory_uc -> lsymbol
+val find_prop : Ptree.qualid -> theory_uc -> Decl.prop
+
+
+(** Specialization *)
+
+val specialize_tysymbol : 
+  loc:Ptree.loc -> Ptree.qualid -> denv -> Ty.tysymbol * type_var list
+
+val specialize_lsymbol  : 
+  loc:Ptree.loc -> lsymbol -> lsymbol * dty list * dty option
+
+
+(** Error reporting *)
+
+type error
+
+exception Error of error
+
+val report : Format.formatter -> error -> unit
+

src/parser/typing.ml

@@ -27,6 +27,7 @@ open Term
 open Decl
 open Theory
 open Env
+open Denv
 
 (** errors *)
 
@@ -34,18 +35,15 @@ type error =
   | Message of string
   | ClashType of string
   | DuplicateTypeVar of string
-  | UnboundType of string
   | TypeArity of qualid * int * int
   | Clash of string
   | PredicateExpected
   | TermExpected
-  | UnboundSymbol of string
   | BadNumberOfArguments of Ident.ident * int * int 
   | ClashTheory of string
   | ClashNamespace of string
   | UnboundTheory of qualid
   | AlreadyTheory of string
-  | UnboundNamespace of string
   | UnboundFile of string
   | UnboundDir of string
   | AmbiguousPath of string * string
@@ -82,8 +80,6 @@ let report fmt = function
       fprintf fmt "clash with previous type %s" s
   | DuplicateTypeVar s ->
       fprintf fmt "duplicate type parameter %s" s
-  | UnboundType s ->
-       fprintf fmt "Unbound type '%s'" s
   | TypeArity (id, a, n) ->
       fprintf fmt "@[The type %a expects %d argument(s),@ " print_qualid id a;
       fprintf fmt "but is applied to %d argument(s)@]" n
@@ -93,8 +89,6 @@ let report fmt = function
       fprintf fmt "syntax error: predicate expected"
   | TermExpected ->
       fprintf fmt "syntax error: term expected"
-  | UnboundSymbol s ->
-       fprintf fmt "Unbound symbol '%s'" s
   | BadNumberOfArguments (s, n, m) ->
       fprintf fmt "@[Symbol `%s' is applied to %d terms,@ " s.id_short n;
       fprintf fmt "but is expecting %d arguments@]" m
@@ -106,8 +100,6 @@ let report fmt = function
       fprintf fmt "unbound theory %a" print_qualid q
   | AlreadyTheory s ->
       fprintf fmt "already using a theory with name %s" s
-  | UnboundNamespace s ->
-      fprintf fmt "unbound namespace %s" s
   | UnboundFile s ->
       fprintf fmt "no such file %s" s
   | UnboundDir s ->
@@ -136,171 +128,11 @@ let report fmt = function
 
 *)
 
-(** types with destructive type variables *)
-
-type dty =
-  | Tyvar of type_var
-  | Tyapp of tysymbol * dty list
-      
-and type_var = { 
-  tag : int; 
-  user : bool;
-  tvsymbol : tvsymbol;
-  mutable type_val : dty option;
-  type_var_loc : loc option;
-}
-
-let rec print_dty fmt = function
-  | Tyvar { type_val = Some t } ->
-      print_dty fmt t
-  | Tyvar { type_val = None; tvsymbol = v } ->
-      fprintf fmt "'%s" v.tv_name.id_short
-  | Tyapp (s, []) ->
-      fprintf fmt "%s" s.ts_name.id_short
-  | Tyapp (s, [t]) -> 
-      fprintf fmt "%a %s" print_dty t s.ts_name.id_short
-  | Tyapp (s, l) -> 
-      fprintf fmt "(%a) %s" 
-	(print_list comma print_dty) l s.ts_name.id_short
-
 let term_expected_type ~loc ty1 ty2 =
   errorm ~loc
     "@[This term has type %a@ but is expected to have type@ %a@]"
     print_dty ty1 print_dty ty2
 
-let create_ty_decl_var =
-  let t = ref 0 in
-  fun ?loc ~user tv -> 
-    incr t; 
-    { tag = !t; user = user; tvsymbol = tv; type_val = None;
-      type_var_loc = loc }
-
-let rec occurs v = function
-  | Tyvar { type_val = Some t } -> occurs v t
-  | Tyvar { tag = t; type_val = None } -> v.tag = t
-  | Tyapp (_, l) -> List.exists (occurs v) l
-
-(* destructive type unification *)
-let rec unify t1 t2 = match t1, t2 with
-  | Tyvar { type_val = Some t1 }, _ ->
-      unify t1 t2
-  | _, Tyvar { type_val = Some t2 } ->
-      unify t1 t2
-  | Tyvar v1, Tyvar v2 when v1.tag = v2.tag ->
-      true
-	(* instantiable variables *)
-  | Tyvar ({user=false} as v), t
-  | t, Tyvar ({user=false} as v) ->
-      not (occurs v t) && (v.type_val <- Some t; true)
-	(* recursive types *)
-  | Tyapp (s1, l1), Tyapp (s2, l2) ->
-      s1 == s2 && List.length l1 = List.length l2 &&
-	  List.for_all2 unify l1 l2
-  | Tyapp _, _ | _, Tyapp _ ->
-      false
-	(* other cases *)
-  | Tyvar {user=true; tag=t1}, Tyvar {user=true; tag=t2} -> 
-      t1 = t2
-
-(** Destructive typing environment, that is
-    environment + local variables.
-    It is only local to this module and created with [create_denv] below. *)
-
-type denv = { 
-  th : theory_uc; (* the theory under construction *)
-  utyvars : (string, type_var) Hashtbl.t; (* user type variables *)
-  dvars : dty Mstr.t; (* local variables, to be bound later *)
-}
-
-let create_denv th = { 
-  th = th; 
-  utyvars = Hashtbl.create 17; 
-  dvars = Mstr.empty;
-}
-
-let find_user_type_var x env =
-  try
-    Hashtbl.find env.utyvars x
-  with Not_found ->
-    (* TODO: shouldn't we localize this ident? *)
-    let v = create_tvsymbol (id_fresh x) in
-    let v = create_ty_decl_var ~user:true v in
-    Hashtbl.add env.utyvars x v;
-    v
- 
-(* Specialize *)
-
-let find_type_var ~loc env tv =
-  try
-    Htv.find env tv
-  with Not_found ->
-    let v = create_ty_decl_var ~loc ~user:false tv in
-    Htv.add env tv v;
-    v
- 
-let rec specialize ~loc env t = match t.ty_node with
-  | Ty.Tyvar tv -> 
-      Tyvar (find_type_var ~loc env tv)
-  | Ty.Tyapp (s, tl) ->
-      Tyapp (s, List.map (specialize ~loc env) tl)
-
-(** generic find function using a path *)
-
-let find_local_namespace {id=x; id_loc=loc} ns = 
-  try Mnm.find x ns.ns_ns
-  with Not_found -> error ~loc (UnboundNamespace x)
-
-let rec find_namespace q ns = match q with
-  | Qident t -> find_local_namespace t ns
-  | Qdot (q, t) -> let ns = find_namespace q ns in find_local_namespace t ns
-
-let rec find f q ns = match q with
-  | Qident x -> f x ns
-  | Qdot (m, x) -> let ns = find_namespace m ns in f x ns
-
-(** specific find functions using a path *)
-
-let find_local_tysymbol {id=x; id_loc=loc} ns = 
-  try Mnm.find x ns.ns_ts
-  with Not_found -> error ~loc (UnboundType x)
-
-let find_tysymbol_ns p ns =
-  find find_local_tysymbol p ns
-
-let find_tysymbol p th = 
-  find_tysymbol_ns p (get_namespace th)
-
-let specialize_tysymbol ~loc x env =
-  let s = find_tysymbol x env.th in
-  let env = Htv.create 17 in
-  s, List.map (find_type_var ~loc env) s.ts_args
-	
-let find_lsymbol {id=x; id_loc=loc} ns = 
-  try Mnm.find x ns.ns_ls
-  with Not_found -> error ~loc (UnboundSymbol x)
-
-let find_lsymbol_ns p ns = 
-  find find_lsymbol p ns
-
-let find_lsymbol p th = 
-  find_lsymbol_ns p (get_namespace th)
-
-let find_prop {id=x; id_loc=loc} ns = 
-  try Mnm.find x ns.ns_pr
-  with Not_found -> errorm ~loc "unbound formula %s" x
-
-let find_prop_ns p ns =
-  find find_prop p ns
-
-let find_prop p th =
-  find_prop_ns p (get_namespace th)
-
-let specialize_lsymbol ~loc s =
-  let tl = s.ls_args in
-  let t = s.ls_value in
-  let env = Htv.create 17 in
-  s, List.map (specialize ~loc env) tl, option_map (specialize ~loc env) t
-
 let specialize_fsymbol ~loc s = 
   let s, tl, ty = specialize_lsymbol ~loc s in
   match ty with
@@ -313,6 +145,7 @@ let specialize_psymbol ~loc s =
     | None -> s, tl
     | Some _ -> error ~loc PredicateExpected
 
+
 (** Typing types *)
 
 let rec qloc = function
@@ -327,41 +160,6 @@ let split_qualid = function
   | Qident id -> [], id.id
   | Qdot (p, id) -> string_list_of_qualid [] p, id.id
 
-(* parsed types -> intermediate types *)
-
-let rec type_inst s ty = match ty.ty_node with
-  | Ty.Tyvar n -> Mtv.find n s
-  | Ty.Tyapp (ts, tyl) -> Tyapp (ts, List.map (type_inst s) tyl)
-
-let rec dty env = function
-  | PPTtyvar {id=x} -> 
-      Tyvar (find_user_type_var x env)
-  | PPTtyapp (p, x) ->
-      let loc = qloc x in
-      let ts, tv = specialize_tysymbol ~loc x env in
-      let np = List.length p in
-      let a = List.length tv in
-      if np <> a then error ~loc (TypeArity (x, a, np));
-      let tyl = List.map (dty env) p in
-      match ts.ts_def with
-	| None -> 
-	    Tyapp (ts, tyl)
-	| Some ty -> 
-	    let add m v t = Mtv.add v t m in
-            let s = List.fold_left2 add Mtv.empty ts.ts_args tyl in
-	    type_inst s ty
-
-(* intermediate types -> types *)
-let rec ty_of_dty = function
-  | Tyvar { type_val = Some t } ->
-      ty_of_dty t
-  | Tyvar { type_val = None; user = false; type_var_loc = loc } ->
-      errorm ?loc "undefined type variable"
-  | Tyvar { tvsymbol = tv } ->
-      Ty.ty_var tv
-  | Tyapp (s, tl) ->
-      Ty.ty_app s (List.map ty_of_dty tl)
-
 (** Typing terms and formulas *)
 
 type dpattern = { dp_node : dpattern_node; dp_ty : dty }