Attention une mise à jour du serveur va être effectuée le lundi 17 mai entre 13h et 13h30. Cette mise à jour va générer une interruption du service de quelques minutes.

typage du cast

parent a3ca682c
theory Test
axiom A : forall x:int. (x : real) = x
end
theory Test
axiom A : forall x,x:int. x=x
end
...@@ -439,12 +439,14 @@ lexpr: ...@@ -439,12 +439,14 @@ lexpr:
{ mk_pp PPfalse } { mk_pp PPfalse }
| LEFTPAR lexpr RIGHTPAR | LEFTPAR lexpr RIGHTPAR
{ $2 } { $2 }
| ident_or_string COLON lexpr %prec prec_named | STRING lexpr %prec prec_named
{ mk_pp (PPnamed ($1, $3)) } { mk_pp (PPnamed ($1, $2)) }
| LET lident EQUAL lexpr IN lexpr | LET lident EQUAL lexpr IN lexpr
{ mk_pp (PPlet ($2, $4, $6)) } { mk_pp (PPlet ($2, $4, $6)) }
| MATCH lexpr WITH bar_ match_cases END | MATCH lexpr WITH bar_ match_cases END
{ mk_pp (PPmatch ($2, $5)) } { mk_pp (PPmatch ($2, $5)) }
| lexpr COLON primitive_type
{ mk_pp (PPcast ($1, $3)) }
; ;
list1_uquant_sep_comma: list1_uquant_sep_comma:
...@@ -503,11 +505,6 @@ list1_type_var_sep_comma: ...@@ -503,11 +505,6 @@ list1_type_var_sep_comma:
| type_var COMMA list1_type_var_sep_comma { $1 :: $3 } | type_var COMMA list1_type_var_sep_comma { $1 :: $3 }
; ;
ident_or_string:
| ident { $1.id }
| STRING { $1 }
;
bar_: bar_:
| /* epsilon */ { () } | /* epsilon */ { () }
| BAR { () } | BAR { () }
......
...@@ -73,6 +73,7 @@ and pp_desc = ...@@ -73,6 +73,7 @@ and pp_desc =
| PPnamed of string * lexpr | PPnamed of string * lexpr
| PPlet of ident * lexpr * lexpr | PPlet of ident * lexpr * lexpr
| PPmatch of lexpr * (pattern * lexpr) list | PPmatch of lexpr * (pattern * lexpr) list
| PPcast of lexpr * pty
(*s Declarations. *) (*s Declarations. *)
......
...@@ -38,8 +38,6 @@ type error = ...@@ -38,8 +38,6 @@ type error =
| PredicateExpected | PredicateExpected
| TermExpected | TermExpected
| UnboundSymbol of string | UnboundSymbol of string
| TermExpectedType of (formatter -> unit) * (formatter -> unit)
(* actual / expected *)
| BadNumberOfArguments of Ident.ident * int * int | BadNumberOfArguments of Ident.ident * int * int
| ClashTheory of string | ClashTheory of string
| ClashNamespace of string | ClashNamespace of string
...@@ -98,9 +96,6 @@ let report fmt = function ...@@ -98,9 +96,6 @@ let report fmt = function
| BadNumberOfArguments (s, n, m) -> | BadNumberOfArguments (s, n, m) ->
fprintf fmt "@[Symbol `%s' is applied to %d terms,@ " s.id_short n; fprintf fmt "@[Symbol `%s' is applied to %d terms,@ " s.id_short n;
fprintf fmt "but is expecting %d arguments@]" m fprintf fmt "but is expecting %d arguments@]" m
| TermExpectedType (ty1, ty2) ->
fprintf fmt "@[This term has type "; ty1 fmt;
fprintf fmt "@ but is expected to have type@ "; ty2 fmt; fprintf fmt "@]"
| ClashTheory s -> | ClashTheory s ->
fprintf fmt "clash with previous theory %s" s fprintf fmt "clash with previous theory %s" s
| ClashNamespace s -> | ClashNamespace s ->
...@@ -179,6 +174,11 @@ let rec print_dty fmt = function ...@@ -179,6 +174,11 @@ let rec print_dty fmt = function
fprintf fmt "(%a) %s" fprintf fmt "(%a) %s"
(print_list comma print_dty) l s.ts_name.id_short (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_type_var = let create_type_var =
let t = ref 0 in let t = ref 0 in
fun ?loc ~user tv -> fun ?loc ~user tv ->
...@@ -505,6 +505,12 @@ and dterm_node loc env = function ...@@ -505,6 +505,12 @@ and dterm_node loc env = function
| PPnamed (x, e1) -> | PPnamed (x, e1) ->
let e1 = dterm env e1 in let e1 = dterm env e1 in
Tnamed (x, e1), e1.dt_ty Tnamed (x, e1), e1.dt_ty
| PPcast (e1, ty) ->
let loc = e1.pp_loc in
let e1 = dterm env e1 in
let ty = dty env ty in
if not (unify e1.dt_ty ty) then term_expected_type ~loc e1.dt_ty ty;
e1.dt_node, ty
| PPquant _ | PPif _ | PPquant _ | PPif _
| PPprefix _ | PPinfix _ | PPfalse | PPtrue -> | PPprefix _ | PPinfix _ | PPfalse | PPtrue ->
error ~loc TermExpected error ~loc TermExpected
...@@ -568,7 +574,7 @@ and dfmla env e = match e.pp_desc with ...@@ -568,7 +574,7 @@ and dfmla env e = match e.pp_desc with
Fnamed (x, f1) Fnamed (x, f1)
| PPvar _ -> | PPvar _ ->
assert false (* TODO *) assert false (* TODO *)
| PPconst _ -> | PPconst _ | PPcast _ ->
error ~loc:e.pp_loc PredicateExpected error ~loc:e.pp_loc PredicateExpected
and dtype_args s loc env el tl = and dtype_args s loc env el tl =
...@@ -580,9 +586,7 @@ and dtype_args s loc env el tl = ...@@ -580,9 +586,7 @@ and dtype_args s loc env el tl =
| a :: al, t :: bl -> | a :: al, t :: bl ->
let loc = t.pp_loc in let loc = t.pp_loc in
let t = dterm env t in let t = dterm env t in
if not (unify a t.dt_ty) then if not (unify a t.dt_ty) then term_expected_type ~loc t.dt_ty a;
error ~loc (TermExpectedType ((fun f -> print_dty f t.dt_ty),
(fun f -> print_dty f a)));
t :: check_arg (al, bl) t :: check_arg (al, bl)
| _ -> | _ ->
assert false assert false
...@@ -853,9 +857,7 @@ let add_logics loc dl th = ...@@ -853,9 +857,7 @@ let add_logics loc dl th =
in in
let env = env_of_vsymbol_list vl in let env = env_of_vsymbol_list vl in
try Some (make_fs_defn fs vl (term env t)) try Some (make_fs_defn fs vl (term env t))
with _ -> error ~loc (TermExpectedType with _ -> term_expected_type ~loc t.dt_ty (dty denv ty)
((fun f -> print_dty f t.dt_ty),
(fun f -> print_dty f (dty denv ty))))
in in
Lfunction (fs, defn) Lfunction (fs, defn)
in in
......
...@@ -4,7 +4,7 @@ ...@@ -4,7 +4,7 @@
theory A theory A
use import prelude.Int use import prelude.Int
logic p(int, int) logic p(int, int)
axiom A : forall x,y:int, z,t:real. x=x axiom A : forall x:int. x = x
end end
theory TreeForest theory TreeForest
......
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