simon/sidekick
1
0
Fork 0
mirror of https://github.com/c-cube/sidekick.git synced 2026-01-29 04:44:52 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

[WIP] Strange compiler bug

Browse source
This commit is contained in:
Guillaume Bury 2016-09-09 12:07:13 +02:00
parent 742f8c469d
commit 954892ac4a
2 changed files with 30 additions and 4 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
src/main.ml
View file

@ -115,6 +115,29 @@ let check () =
else if s > !size_limit then else if s > !size_limit then
raise Out_of_space raise Out_of_space
let do_task
(module S : Msat.External.S
with type St.formula = Expr.atom) s =
match s.Dolmen.Statement.descr with
| Dolmen.Statement.Def (id, t) -> Type.new_def id t
| Dolmen.Statement.Decl (id, t) -> Type.new_decl id t
| Dolmen.Statement.Consequent t ->
let f = Type.new_formula t in
let cnf = Expr.Formula.make_cnf f in
S.assume cnf
| Dolmen.Statement.Antecedent t ->
let f = Expr.Formula.make_not @@ Type.new_formula t in
let cnf = Expr.Formula.make_cnf f in
S.assume cnf
| Dolmen.Statement.Prove ->
begin match S.solve () with
| S.Sat _ -> ()
| S.Unsat _ -> ()
end
| _ ->
Format.printf "Command not supported:@\n%a@."
Dolmen.Statement.print s
let main () = let main () =
(* Administrative duties *) (* Administrative duties *)
Arg.parse argspec input_file usage; Arg.parse argspec input_file usage;

11
src/util/type.ml
View file

@ -103,7 +103,7 @@ let def_term id ty_args args body =
(* ************************************************************************ *) (* ************************************************************************ *)
(* Make a new empty environment *) (* Make a new empty environment *)
let empty_env ?(expect=Nothing) = { let empty_env ?(expect=Nothing) () = {
type_vars = M.empty; type_vars = M.empty;
term_vars = M.empty; term_vars = M.empty;
term_lets = M.empty; term_lets = M.empty;
@ -595,7 +595,8 @@ let rec parse_fun ty_args t_args env = function
(* High-level parsing functions *) (* High-level parsing functions *)
(* ************************************************************************ *) (* ************************************************************************ *)
let new_decl env t id = let new_decl id t =
let env = empty_env () in
Log.debugf 5 "Typing declaration: %s : %a" Log.debugf 5 "Typing declaration: %s : %a"
(fun k -> k id.Id.name Ast.print t); (fun k -> k id.Id.name Ast.print t);
begin match parse_sig env t with begin match parse_sig env t with
@ -604,7 +605,8 @@ let new_decl env t id =
decl_term id (Expr.Id.term_fun id.Id.name vars args ret) decl_term id (Expr.Id.term_fun id.Id.name vars args ret)
end end
let new_def env t id = let new_def id t =
let env = empty_env () in
Log.debugf 5 "Typing definition: %s = %a" Log.debugf 5 "Typing definition: %s = %a"
(fun k -> k id.Id.name Ast.print t); (fun k -> k id.Id.name Ast.print t);
begin match parse_fun [] [] env t with begin match parse_fun [] [] env t with
@ -612,7 +614,8 @@ let new_def env t id =
| `Term (ty_args, t_args, body) -> def_term id ty_args t_args body | `Term (ty_args, t_args, body) -> def_term id ty_args t_args body
end end
let new_formula env t = let new_formula t =
let env = empty_env () in
Log.debugf 5 "Typing top-level formula: %a" (fun k -> k Ast.print t); Log.debugf 5 "Typing top-level formula: %a" (fun k -> k Ast.print t);
let res = parse_formula env t in let res = parse_formula env t in
res res