symboles primitifs

parent f525847b
......@@ -3,8 +3,6 @@
theory Int
type int
logic (<) (int, int)
logic (<=)(int, int)
logic (>) (int, int)
......
......@@ -324,15 +324,38 @@ let add_symbol add id v uc =
let get_namespace uc = List.hd uc.uc_import
(** Equality *)
(** Builtin symbols *)
let t_int = create_tysymbol (id_fresh "int") [] None
let t_real = create_tysymbol (id_fresh "real") [] None
let eq =
let v = ty_var (create_tvsymbol (id_fresh "a")) in
create_psymbol (id_fresh "eq") [v; v;]
create_psymbol (id_fresh "=") [v; v;]
let neq =
let v = ty_var (create_tvsymbol (id_fresh "a")) in
create_psymbol (id_fresh "<>") [v; v;]
let builtin_tysymbols = [t_int; t_real]
let builtin_psymbols = [eq; neq]
let eq_th = id_register (id_fresh "Eq")
let ts_name x = x.ts_name
let ps_name x = x.ps_name
let known_eq = Mid.add eq.ps_name eq_th Mid.empty
let builtin_ns =
let add adder name = List.fold_right (fun s -> adder (name s).id_short s) in
let ns = add add_ts ts_name builtin_tysymbols empty_ns in
let ns = add add_ps ps_name builtin_psymbols ns in
ns
let builtin_th = id_register (id_fresh "Builtin")
let builtin_known =
let add name = List.fold_right (fun s -> Mid.add (name s) builtin_th) in
let kn = Mid.add builtin_th builtin_th Mid.empty in
let kn = add ts_name builtin_tysymbols kn in
let kn = add ps_name builtin_psymbols kn in
kn
(** Manage theories *)
......@@ -340,8 +363,8 @@ let known_eq = Mid.add eq.ps_name eq_th Mid.empty
let create_theory n = {
uc_name = n;
uc_param = Sid.empty;
uc_known = Mid.add n n known_eq;
uc_import = [empty_ns];
uc_known = Mid.add n n builtin_known;
uc_import = [builtin_ns];
uc_export = [empty_ns];
uc_decls = [];
}
......@@ -511,6 +534,6 @@ let print_t fmt t =
(*
Local Variables:
compile-command: "make -C .. test"
compile-command: "make -C ../.. test"
End:
*)
......@@ -43,7 +43,6 @@
(fun (x,y) -> Hashtbl.add keywords x y)
[ "absurd", ABSURD;
"and", AND;
(*"array", ARRAY;*)
"as", AS;
"assert", ASSERT;
"axiom", AXIOM;
......@@ -69,7 +68,6 @@
"import", IMPORT;
"in", IN;
"inductive", INDUCTIVE;
(*"int", INT;*)
"invariant", INVARIANT;
"lemma", LEMMA;
"let", LET;
......@@ -85,7 +83,6 @@
"raise", RAISE;
"raises", RAISES;
"reads", READS;
"real", REAL;
"rec", REC;
"ref", REF;
"returns", RETURNS;
......@@ -194,9 +191,7 @@ rule token = parse
{ LRARROW }
| "="
{ EQUAL }
| "<>"
{ NOTEQ }
| "<" | "<=" | ">" | ">=" as s
| "<>" | "<" | "<=" | ">" | ">=" as s
{ INFIXOP0 s }
| "+"
{ INFIXOP2 "+" }
......
......@@ -101,11 +101,11 @@
%token DONE DOT ELSE END EOF EQUAL
%token EXCEPTION EXISTS EXPORT EXTERNAL FALSE FOR FORALL FPI
%token FUN FUNCTION GOAL
%token IF IMPORT IN INCLUDE INDUCTIVE INT INVARIANT
%token IF IMPORT IN INCLUDE INDUCTIVE INVARIANT
%token LEFTB LEFTBLEFTB LEFTPAR LEFTSQ LEMMA
%token LET LOGIC LRARROW MATCH MINUS
%token NAMESPACE NOT NOTEQ OF OR PARAMETER PREDICATE PROP
%token QUOTE RAISE RAISES READS REAL REC REF RETURNS RIGHTB RIGHTBRIGHTB
%token NAMESPACE NOT OF OR PARAMETER PREDICATE PROP
%token QUOTE RAISE RAISES READS REC REF RETURNS RIGHTB RIGHTBRIGHTB
%token RIGHTPAR RIGHTSQ
%token SEMICOLON SLASH
%token THEN THEORY TIMES TRUE TRY TYPE UNDERSCORE
......@@ -136,7 +136,7 @@
%right AND AMPAMP
%right NOT
%right prec_if
%left EQUAL NOTEQ INFIXOP0
%left EQUAL INFIXOP0
%left INFIXOP2 MINUS
%left INFIXOP3
%right uminus
......@@ -190,6 +190,7 @@ lident_infix:
| INFIXOP0 { $1 }
| INFIXOP2 { $1 }
| INFIXOP3 { $1 }
| EQUAL { "=" }
| MINUS { "-" }
......@@ -342,16 +343,6 @@ indcase:
;
primitive_type:
/*
| INT
{ PPTint }
| BOOL
{ PPTbool }
| REAL
{ PPTreal }
| UNIT
{ PPTunit }
*/
| type_var
{ PPTtyvar $1 }
| lqualid
......@@ -383,9 +374,8 @@ lexpr:
| NOT lexpr
{ prefix_pp PPnot $2 }
| lexpr EQUAL lexpr
{ infix_pp $1 PPeq $3 }
| lexpr NOTEQ lexpr
{ infix_pp $1 PPneq $3 }
{ let id = { id = "="; id_loc = loc_i 2 } in
mk_pp (PPapp (Qident id, [$1; $3])) }
| lexpr INFIXOP0 lexpr
{ let id = { id = $2; id_loc = loc_i 2 } in
mk_pp (PPapp (Qident id, [$1; $3])) }
......
......@@ -32,7 +32,7 @@ type constant =
| ConstFloat of real_constant
type pp_infix =
| PPand | PPor | PPimplies | PPiff | PPeq | PPneq
| PPand | PPor | PPimplies | PPiff
type pp_prefix =
| PPneg | PPnot
......
......@@ -112,23 +112,6 @@ let report fmt = function
| UnboundTypeVar s ->
fprintf fmt "unbound type variable '%s" s
(****
| OpenTheory ->
fprintf fmt "cannot open a new theory in a non-empty context"
| CloseTheory ->
fprintf fmt "cannot close theory: there are still unclosed namespaces"
| NoOpenedTheory ->
fprintf fmt "no opened theory"
| NoOpenedNamespace ->
fprintf fmt "no opened namespace"
| RedeclaredIdent id ->
fprintf fmt "cannot redeclare identifier %s" id.id_short
| CannotInstantiate ->
fprintf fmt "cannot instantiate a defined symbol"
****)
(** Environments *)
......@@ -364,7 +347,6 @@ let binop = function
| PPor -> For
| PPimplies -> Fimplies
| PPiff -> Fiff
| _ -> assert false
let rec dterm env t =
let n, ty = dterm_node t.pp_loc env t.pp_desc in
......@@ -399,10 +381,10 @@ and dfmla env e = match e.pp_desc with
Fnot (dfmla env a)
| PPinfix (a, (PPand | PPor | PPimplies | PPiff as op), b) ->
Fbinop (binop op, dfmla env a, dfmla env b)
| PPinfix (a, (PPeq | PPneq as op), b) ->
let s, _ = specialize_psymbol Theory.eq in
let f = Fapp (s, [dterm env a; dterm env b]) in
if op = PPeq then f else Fnot f
(* | PPinfix (a, (PPeq | PPneq as op), b) -> *)
(* let s, _ = specialize_psymbol Theory.eq in *)
(* let f = Fapp (s, [dterm env a; dterm env b]) in *)
(* if op = PPeq then f else Fnot f *)
| PPif (a, b, c) ->
Fif (dfmla env a, dfmla env b, dfmla env c)
| PPforall ({id=x}, ty, _, a) -> (* TODO: triggers *)
......@@ -473,11 +455,13 @@ and fmla env = function
open Ptree
let add_types loc dl th =
let ns = get_namespace th in
let def =
List.fold_left
(fun def d ->
let id = d.td_ident in
if M.mem id.id def then error ~loc:id.id_loc (ClashType id.id);
if M.mem id.id def || Mnm.mem id.id ns.ns_ts then
error ~loc:id.id_loc (ClashType id.id);
M.add id.id d def)
M.empty dl
in
......
......@@ -3,15 +3,16 @@
theory TestPrelude
use prelude.List
use list.IntList
(* use list.IntList *)
use array.IntArray
end
theory A
use import prelude.Int
type t
logic p(t)
logic q(x: t) = p(x)
logic c : t
logic c : real
end
theory B
......
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