Une MAJ de sécurité est nécessaire sur notre version actuelle. Elle sera effectuée lundi 02/08 entre 12h30 et 13h. L'interruption de service devrait durer quelques minutes (probablement moins de 5 minutes).

Commit e6a5ae99 authored by Jean-Christophe Filliâtre's avatar Jean-Christophe Filliâtre
Browse files

programs: theories local to .mlw files

parent 04b75f47
...@@ -838,28 +838,51 @@ bar_: ...@@ -838,28 +838,51 @@ bar_:
/****************************************************************************/ /****************************************************************************/
program_file: program_file:
| list0_module_ EOF { $1 } | list0_theory_or_module_ EOF { $1 }
; ;
list0_module_: list0_theory_or_module_:
| /* epsilon */ | /* epsilon */
{ [] } { [] }
| list1_module_ | list1_theory_or_module_
{ $1 } { $1 }
; ;
list1_module_: list1_theory_or_module_:
| module_ | theory_or_module_
{ [$1] } { [$1] }
| module_ list1_module_ | theory_or_module_ list1_theory_or_module_
{ $1 :: $2 } { $1 :: $2 }
; ;
module_: theory_or_module_:
| THEORY uident labels list0_full_decl END
{ { mod_name = $2; mod_labels = $3; mod_decl = $4 } }
| MODULE uident labels list0_program_decl END | MODULE uident labels list0_program_decl END
{ { mod_name = $2; mod_labels = $3; mod_decl = $4 } } { { mod_name = $2; mod_labels = $3; mod_decl = $4 } }
; ;
list0_full_decl:
| /* epsilon */
{ [] }
| list1_full_decl
{ $1 }
;
list1_full_decl:
| full_decl
{ [$1] }
| full_decl list1_full_decl
{ $1 :: $2 }
;
full_decl:
| NAMESPACE namespace_import namespace_name list0_full_decl END
{ Dnamespace (loc_i 3, $3, $2, $4) }
| decl
{ Dlogic $1 }
;
list0_program_decl: list0_program_decl:
| /* epsilon */ | /* epsilon */
{ [] } { [] }
...@@ -891,8 +914,8 @@ program_decl: ...@@ -891,8 +914,8 @@ program_decl:
{ Dexn (add_lab $2 $3, Some $4) } { Dexn (add_lab $2 $3, Some $4) }
| USE use_module | USE use_module
{ $2 } { $2 }
| NAMESPACE namespace_import uident list0_program_decl END | NAMESPACE namespace_import namespace_name list0_program_decl END
{ Dnamespace ($3, $2, $4) } { Dnamespace (loc_i 3, $3, $2, $4) }
| ABSTRACT TYPE lident type_args model | ABSTRACT TYPE lident type_args model
{ Dmodel_type (false, $3, $4, $5) } { Dmodel_type (false, $3, $4, $5) }
| MUTABLE TYPE lident type_args model | MUTABLE TYPE lident type_args model
......
...@@ -229,7 +229,7 @@ type program_decl = ...@@ -229,7 +229,7 @@ type program_decl =
| Dexn of ident * pty option | Dexn of ident * pty option
(* modules *) (* modules *)
| Duse of qualid * imp_exp * (*as:*) ident option | Duse of qualid * imp_exp * (*as:*) ident option
| Dnamespace of ident * (* import: *) bool * program_decl list | Dnamespace of loc * ident option * (* import: *) bool * program_decl list
| Dmodel_type of bool * ident * ident list * pty option | Dmodel_type of bool * ident * ident list * pty option
type module_ = { type module_ = {
......
...@@ -18,15 +18,18 @@ ...@@ -18,15 +18,18 @@
(**************************************************************************) (**************************************************************************)
open Why open Why
open Theory
open Pgm_module open Pgm_module
type module_file = Theory.theory Mnm.t * Pgm_module.t Mnm.t
type t = { type t = {
env : Env.env; env : Env.env;
retrieve : retrieve_module; retrieve : retrieve_module;
memo : (string list, Pgm_module.t Mnm.t) Hashtbl.t; memo : (string list, module_file) Hashtbl.t;
} }
and retrieve_module = t -> string -> in_channel -> Pgm_module.t Mnm.t and retrieve_module = t -> string -> in_channel -> module_file
let get_env penv = penv.env let get_env penv = penv.env
...@@ -44,15 +47,16 @@ let rec add_suffix = function ...@@ -44,15 +47,16 @@ let rec add_suffix = function
| p :: f -> p :: add_suffix f | p :: f -> p :: add_suffix f
let find_library penv sl = let find_library penv sl =
try Hashtbl.find penv.memo sl try
Hashtbl.find penv.memo sl
with Not_found -> with Not_found ->
Hashtbl.add penv.memo sl Mnm.empty; Hashtbl.add penv.memo sl (Mnm.empty, Mnm.empty);
let file, c = Env.find_channel penv.env (add_suffix sl) in let file, c = Env.find_channel penv.env (add_suffix sl) in
let m = penv.retrieve penv file c in let r = penv.retrieve penv file c in
close_in c; close_in c;
Hashtbl.replace penv.memo sl m; Hashtbl.replace penv.memo sl r;
m r
let find_module penv sl s = let find_module penv sl s =
try Mnm.find s (find_library penv sl) try Mnm.find s (snd (find_library penv sl))
with Not_found -> raise (ModuleNotFound (sl, s)) with Not_found -> raise (ModuleNotFound (sl, s))
...@@ -18,13 +18,16 @@ ...@@ -18,13 +18,16 @@
(**************************************************************************) (**************************************************************************)
open Why open Why
open Theory
open Pgm_module open Pgm_module
type t type t
val get_env : t -> Env.env val get_env : t -> Env.env
type retrieve_module = t -> string -> in_channel -> Pgm_module.t Mnm.t type module_file = Theory.theory Mnm.t * Pgm_module.t Mnm.t
type retrieve_module = t -> string -> in_channel -> module_file
val create : Env.env -> retrieve_module -> t val create : Env.env -> retrieve_module -> t
......
...@@ -23,17 +23,29 @@ open Format ...@@ -23,17 +23,29 @@ open Format
open Why open Why
open Util open Util
open Ident open Ident
open Theory
open Ptree open Ptree
open Pgm_module open Pgm_module
let add_module ?(type_only=false) env penv lmod m = exception ClashModule of string
let wp = not type_only in
let () = Exn_printer.register (fun fmt e -> match e with
| ClashModule m -> fprintf fmt "clash with previous module %s" m
| _ -> raise e)
let add_module ?(type_only=false) env penv (ltm, lmod) m =
let id = m.mod_name in let id = m.mod_name in
let uc = create_module (Ident.id_user id.id id.id_loc) in let loc = id.id_loc in
if Mnm.mem id.id lmod then raise (Loc.Located (loc, ClashModule id.id));
let wp = not type_only in
let uc = create_module (Ident.id_user id.id loc) in
let prelude = Env.find_theory env ["programs"] "Prelude" in let prelude = Env.find_theory env ["programs"] "Prelude" in
let uc = use_export_theory uc prelude in let uc = use_export_theory uc prelude in
let uc = List.fold_left (Pgm_typing.decl ~wp env penv lmod) uc m.mod_decl in let uc =
List.fold_left (Pgm_typing.decl ~wp env penv ltm lmod) uc m.mod_decl
in
let m = close_module uc in let m = close_module uc in
Mnm.add id.id m.m_th ltm,
Mnm.add id.id m lmod Mnm.add id.id m lmod
let retrieve penv file c = let retrieve penv file c =
...@@ -41,11 +53,12 @@ let retrieve penv file c = ...@@ -41,11 +53,12 @@ let retrieve penv file c =
Loc.set_file file lb; Loc.set_file file lb;
let ml = Lexer.parse_program_file lb in let ml = Lexer.parse_program_file lb in
if Debug.test_flag Typing.debug_parse_only then if Debug.test_flag Typing.debug_parse_only then
Mnm.empty Mnm.empty, Mnm.empty
else else
let type_only = Debug.test_flag Typing.debug_type_only in let type_only = Debug.test_flag Typing.debug_type_only in
let env = Pgm_env.get_env penv in let env = Pgm_env.get_env penv in
List.fold_left (add_module ~type_only env penv) Mnm.empty ml List.fold_left (add_module ~type_only env penv)
(Mnm.empty, Mnm.empty) ml
let pgm_env_of_env = let pgm_env_of_env =
let h = Env.Wenv.create 17 in let h = Env.Wenv.create 17 in
...@@ -59,10 +72,8 @@ let pgm_env_of_env = ...@@ -59,10 +72,8 @@ let pgm_env_of_env =
let read_channel env file c = let read_channel env file c =
let penv = pgm_env_of_env env in let penv = pgm_env_of_env env in
let mm = retrieve penv file c in let tm, _ = retrieve penv file c in
Mnm.fold tm
(fun _ m tm -> Theory.Mnm.add m.m_name.id_string m.m_th tm)
mm Theory.Mnm.empty
let () = Env.register_format "whyml" ["mlw"] read_channel let () = Env.register_format "whyml" ["mlw"] read_channel
......
...@@ -9,8 +9,6 @@ open Pgm_types ...@@ -9,8 +9,6 @@ open Pgm_types
open Pgm_types.T open Pgm_types.T
open Pgm_ttree open Pgm_ttree
module Mnm = Mstr
type namespace = { type namespace = {
ns_pr : psymbol Mnm.t; (* program symbols *) ns_pr : psymbol Mnm.t; (* program symbols *)
ns_ex : esymbol Mnm.t; (* exceptions*) ns_ex : esymbol Mnm.t; (* exceptions*)
...@@ -182,8 +180,8 @@ let use_export uc m = ...@@ -182,8 +180,8 @@ let use_export uc m =
let use_export_theory uc th = let use_export_theory uc th =
{ uc with uc_th = Theory.use_export uc.uc_th th } { uc with uc_th = Theory.use_export uc.uc_th th }
let add_logic_pdecl env d uc = let add_logic_pdecl env ltm d uc =
{ uc with uc_th = Typing.add_decl env Theory.Mnm.empty uc.uc_th d } { uc with uc_th = Typing.add_decl env ltm uc.uc_th d }
......
...@@ -2,11 +2,10 @@ ...@@ -2,11 +2,10 @@
open Why open Why
open Ident open Ident
open Term open Term
open Theory
open Pgm_types open Pgm_types
open Pgm_types.T open Pgm_types.T
module Mnm : Map.S with type key = string
type namespace = private { type namespace = private {
ns_pr : psymbol Mnm.t; (* program symbols *) ns_pr : psymbol Mnm.t; (* program symbols *)
ns_ex : esymbol Mnm.t; (* exception symbols *) ns_ex : esymbol Mnm.t; (* exception symbols *)
...@@ -52,7 +51,8 @@ val add_mtsymbol : mtsymbol -> uc -> uc ...@@ -52,7 +51,8 @@ val add_mtsymbol : mtsymbol -> uc -> uc
val add_decl : Pgm_ttree.decl -> uc -> uc val add_decl : Pgm_ttree.decl -> uc -> uc
val add_logic_decl : Decl.decl -> uc -> uc val add_logic_decl : Decl.decl -> uc -> uc
val add_logic_pdecl : Env.env -> Ptree.decl -> uc -> uc val add_logic_pdecl :
Env.env -> Theory.theory Theory.Mnm.t -> Ptree.decl -> uc -> uc
(** exceptions *) (** exceptions *)
......
...@@ -1524,9 +1524,9 @@ let find_module penv lmod q id = match q with ...@@ -1524,9 +1524,9 @@ let find_module penv lmod q id = match q with
(* env = to retrieve theories from the loadpath (* env = to retrieve theories from the loadpath
penv = to retrieve modules from the loadpath penv = to retrieve modules from the loadpath
lmod = local modules *) lmod = local modules *)
let rec decl ~wp env penv lmod uc = function let rec decl ~wp env penv ltm lmod uc = function
| Ptree.Dlogic d -> | Ptree.Dlogic d ->
Pgm_module.add_logic_pdecl env d uc Pgm_module.add_logic_pdecl env ltm d uc
| Ptree.Dlet (id, e) -> | Ptree.Dlet (id, e) ->
let e = type_expr uc e in let e = type_expr uc e in
if Debug.test_flag debug then if Debug.test_flag debug then
...@@ -1598,11 +1598,11 @@ let rec decl ~wp env penv lmod uc = function ...@@ -1598,11 +1598,11 @@ let rec decl ~wp env penv lmod uc = function
with ClashSymbol s -> with ClashSymbol s ->
errorm ~loc "clash with previous symbol %s" s errorm ~loc "clash with previous symbol %s" s
end end
| Ptree.Dnamespace (id, import, dl) -> | Ptree.Dnamespace (loc, id, import, dl) ->
let loc = id.id_loc in
let uc = open_namespace uc in let uc = open_namespace uc in
let uc = List.fold_left (decl ~wp env penv lmod) uc dl in let uc = List.fold_left (decl ~wp env penv ltm lmod) uc dl in
begin try close_namespace uc import (Some id.id) let id = option_map (fun id -> id.id) id in
begin try close_namespace uc import id
with ClashSymbol s -> errorm ~loc "clash with previous symbol %s" s end with ClashSymbol s -> errorm ~loc "clash with previous symbol %s" s end
| Ptree.Dmodel_type (mut, id, args, model) -> | Ptree.Dmodel_type (mut, id, args, model) ->
let loc = id.id_loc in let loc = id.id_loc in
......
...@@ -23,5 +23,7 @@ open Util ...@@ -23,5 +23,7 @@ open Util
val debug : Debug.flag val debug : Debug.flag
val decl : val decl :
wp:bool -> Env.env -> Pgm_env.t -> Pgm_module.t Pgm_module.Mnm.t -> wp:bool -> Env.env -> Pgm_env.t ->
Theory.theory Theory.Mnm.t ->
Pgm_module.t Theory.Mnm.t ->
Pgm_module.uc -> Ptree.program_decl -> Pgm_module.uc Pgm_module.uc -> Ptree.program_decl -> Pgm_module.uc
(* theory T *) theory A
(* type t *) type t
(* end *) end
module P module P
use import module A
use import int.Int use import int.Int
use import module stdlib.Array use import module stdlib.Array
logic c : int
let foo (t : array int) = let foo (t : array int) =
{ A.length t >= 1 && t[0] = 1 } { length t >= 1 && t[0] = 1 }
t[0 <- 1]; t[0 <- 1];
t[0] + 3 t[0] + 3
{ result = 3 } { result = 3 }
end end
(* (*
Local Variables: Local Variables:
compile-command: "unset LANG; make -C .. testl-ide" compile-command: "unset LANG; make -C .. testl-ide"
......
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