Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
why3
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
124
Issues
124
List
Boards
Labels
Service Desk
Milestones
Merge Requests
15
Merge Requests
15
Operations
Operations
Incidents
Packages & Registries
Packages & Registries
Container Registry
Analytics
Analytics
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Commits
Issue Boards
Open sidebar
Why3
why3
Commits
c1012422
Commit
c1012422
authored
Feb 23, 2017
by
Mário Pereira
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Code extraction (wip)
Support for recursive extraction and qualified names
parent
4468ff82
Changes
7
Hide whitespace changes
Inline
Side-by-side
Showing
7 changed files
with
49 additions
and
36 deletions
+49
-36
src/mlw/compile.ml
src/mlw/compile.ml
+18
-4
src/mlw/cprinter.ml
src/mlw/cprinter.ml
+2
-1
src/mlw/ocaml_printer.ml
src/mlw/ocaml_printer.ml
+16
-22
src/mlw/pdriver.ml
src/mlw/pdriver.ml
+1
-1
src/mlw/pdriver.mli
src/mlw/pdriver.mli
+2
-1
src/tools/why3extract.ml
src/tools/why3extract.ml
+8
-5
theories/int.why
theories/int.why
+2
-2
No files found.
src/mlw/compile.ml
View file @
c1012422
...
...
@@ -73,6 +73,20 @@ open Ty
open
Term
open
Printer
let
clean_name
fname
=
(* TODO: replace with Filename.remove_extension
* after migration to OCaml 4.04+ *)
let
remove_extension
s
=
try
Filename
.
chop_extension
s
with
Invalid_argument
_
->
s
in
let
f
=
Filename
.
basename
fname
in
(
remove_extension
f
)
let
module_name
?
fname
path
t
=
let
fname
=
match
fname
,
path
with
|
None
,
"why3"
::_
->
"why3"
|
None
,
_
->
String
.
concat
"__"
path
|
Some
f
,
_
->
clean_name
f
in
fname
^
"__"
^
t
module
ML
=
struct
open
Expr
...
...
@@ -476,8 +490,7 @@ module Translate = struct
|
Eexec
({
c_node
=
Cfun
e
;
c_cty
=
cty
}
,
_
)
->
let
args
=
params
cty
.
cty_args
in
ML
.
mk_expr
(
ML
.
Efun
(
args
,
expr
info
e
))
(
ML
.
I
e
.
e_ity
)
eff
|
Eexec
({
c_node
=
Cany
}
,
_
)
->
raise
ExtractionAny
|
Eexec
({
c_node
=
Cany
}
,
_
)
->
raise
ExtractionAny
(* ML.mk_unit *)
|
Eabsurd
->
ML
.
mk_expr
ML
.
Eabsurd
(
ML
.
I
e
.
e_ity
)
eff
...
...
@@ -570,8 +583,9 @@ module Translate = struct
match
pd
.
pd_node
with
|
PDlet
(
LDsym
(
rs
,
_
))
when
rs_ghost
rs
->
[]
|
PDlet
(
LDsym
(
rs
,
{
c_node
=
Cany
}))
->
raise
(
ExtractionVal
rs
)
|
PDlet
(
LDsym
(
_rs
,
{
c_node
=
Cany
}))
->
[]
(* raise (ExtractionVal _rs) *)
|
PDlet
(
LDsym
({
rs_cty
=
cty
}
as
rs
,
{
c_node
=
Cfun
e
}))
->
let
args
=
params
cty
.
cty_args
in
let
res
=
ity
cty
.
cty_result
in
...
...
src/mlw/cprinter.ml
View file @
c1012422
...
...
@@ -79,10 +79,11 @@ let fg ?fname m =
open
Format
let
pr
args
?
old
fmt
m
=
let
pr
args
?
old
?
fname
fmt
m
=
ignore
(
args
);
ignore
(
old
);
ignore
(
m
);
ignore
(
fname
);
fprintf
fmt
"#include <stdio.h>
\n
\
\n
\
int main() {
\n
\
...
...
src/mlw/ocaml_printer.ml
View file @
c1012422
...
...
@@ -77,7 +77,7 @@ module Print = struct
let
print_qident
~
sanitizer
info
fmt
id
=
try
let
_
,
_
,
q
=
let
lp
,
t
,
q
=
try
Pmodule
.
restore_path
id
with
Not_found
->
Theory
.
restore_path
id
in
let
s
=
String
.
concat
"__"
q
in
...
...
@@ -89,8 +89,8 @@ module Print = struct
false
info
.
info_current_mo
then
fprintf
fmt
"%s"
s
else
(* let fname = if lp = [] then info.info_fname else None in *)
let
m
=
Strings
.
capitalize
"m"
in
let
fname
=
if
lp
=
[]
then
info
.
info_fname
else
None
in
let
m
=
Strings
.
capitalize
(
module_name
?
fname
lp
t
)
in
fprintf
fmt
"%s.%s"
m
s
with
Not_found
->
let
s
=
id_unique
~
sanitizer
iprinter
id
in
...
...
@@ -302,16 +302,19 @@ module Print = struct
forget_let_defn
let_def
|
Eabsurd
->
fprintf
fmt
(
protect_on
paren
"assert false (* absurd *)"
)
|
Eapp
(
s
,
[]
)
when
rs_equal
s
rs_true
->
|
Eapp
(
rs
,
[]
)
when
rs_equal
r
s
rs_true
->
fprintf
fmt
"true"
|
Eapp
(
s
,
[]
)
when
rs_equal
s
rs_false
->
|
Eapp
(
rs
,
[]
)
when
rs_equal
r
s
rs_false
->
fprintf
fmt
"false"
|
Eapp
(
s
,
[
e1
;
e2
])
when
rs_equal
s
rs_func_app
->
|
Eapp
(
rs
,
[
e1
;
e2
])
when
rs_equal
r
s
rs_func_app
->
fprintf
fmt
"@[<hov 1>%a %a@]"
(
print_expr
info
)
e1
(
print_expr
info
)
e2
|
Eapp
(
s
,
pvl
)
->
|
Eapp
(
rs
,
[]
)
->
(* avoids parenthesis around values *)
fprintf
fmt
"%a"
(
print_apply
info
(
Hrs
.
find_def
ht_rs
rs
rs
))
[]
|
Eapp
(
rs
,
pvl
)
->
fprintf
fmt
(
protect_on
paren
"%a"
)
(
print_apply
info
(
Hrs
.
find_def
ht_rs
s
s
))
pvl
(
print_apply
info
(
Hrs
.
find_def
ht_rs
rs
r
s
))
pvl
|
Ematch
(
e
,
pl
)
->
fprintf
fmt
(
protect_on
paren
"begin match @[%a@] with@
\n
@[<hov>%a@]@
\n
end"
)
...
...
@@ -445,7 +448,7 @@ module Print = struct
print_ident
xs
.
xs_name
(
print_ty
~
paren
:
true
info
)
t
end
let
extract_module
pargs
?
old
fmt
({
mod_theory
=
th
}
as
m
)
=
let
extract_module
pargs
?
old
?
fname
fmt
({
mod_theory
=
th
}
as
m
)
=
ignore
(
pargs
);
ignore
(
old
);
ignore
(
m
);
...
...
@@ -456,7 +459,7 @@ let extract_module pargs ?old fmt ({mod_theory = th} as m) =
info_current_mo
=
Some
m
;
info_th_known_map
=
th
.
th_known
;
info_mo_known_map
=
m
.
mod_known
;
info_fname
=
None
;
(* TODO *)
info_fname
=
Opt
.
map
Compile
.
clean_name
fname
}
in
fprintf
fmt
"(* This file has been generated from Why3 module %a *)@
\n
@
\n
"
...
...
@@ -467,18 +470,9 @@ let extract_module pargs ?old fmt ({mod_theory = th} as m) =
fprintf
fmt
"@."
let
fg
?
fname
m
=
let
mod_name
=
m
.
Pmodule
.
mod_theory
.
Theory
.
th_name
.
id_string
in
match
fname
with
|
None
->
mod_name
^
".ml"
|
Some
f
->
(* TODO: replace with Filename.remove_extension
* after migration to OCaml 4.04+ *)
let
remove_extension
s
=
try
Filename
.
chop_extension
s
with
Invalid_argument
_
->
s
in
let
f
=
Filename
.
basename
f
in
(
remove_extension
f
)
^
"__"
^
mod_name
^
".ml"
let
mod_name
=
m
.
mod_theory
.
th_name
.
id_string
in
let
path
=
m
.
mod_theory
.
th_path
in
(
module_name
?
fname
path
mod_name
)
^
".ml"
let
()
=
Pdriver
.
register_printer
"ocaml"
~
desc
:
"printer for OCaml code"
fg
extract_module
...
...
src/mlw/pdriver.ml
View file @
c1012422
...
...
@@ -220,7 +220,7 @@ open Stdlib
type
filename_generator
=
?
fname
:
string
->
Pmodule
.
pmodule
->
string
type
printer
=
printer_args
->
?
old
:
in_channel
->
Pmodule
.
pmodule
Pp
.
pp
type
printer
=
printer_args
->
?
old
:
in_channel
->
?
fname
:
string
->
Pmodule
.
pmodule
Pp
.
pp
type
reg_printer
=
Pp
.
formatted
*
filename_generator
*
printer
...
...
src/mlw/pdriver.mli
View file @
c1012422
...
...
@@ -37,7 +37,8 @@ val load_driver : Env.env -> string -> string list -> driver
@param string driver file name
@param string list additional drivers containing only theories/modules *)
type
printer
=
printer_args
->
?
old
:
in_channel
->
Pmodule
.
pmodule
Pp
.
pp
type
printer
=
printer_args
->
?
old
:
in_channel
->
?
fname
:
string
->
Pmodule
.
pmodule
Pp
.
pp
(* type printer = printer_args -> ?old:in_channel -> ?mono:bool -> Compile.ML.decl Pp.pp *)
type
filename_generator
=
?
fname
:
string
->
Pmodule
.
pmodule
->
string
...
...
src/tools/why3extract.ml
View file @
c1012422
...
...
@@ -50,6 +50,7 @@ let add_opt_theory x =
let
opt_parser
=
ref
None
let
opt_output
=
ref
None
let
opt_driver
=
ref
[]
let
opt_recurs
=
ref
false
let
option_list
=
[
"-"
,
Arg
.
Unit
(
fun
()
->
add_opt_file
"-"
)
,
...
...
@@ -66,6 +67,8 @@ let option_list = [
"<file> specify an extraction driver"
;
"--driver"
,
Arg
.
String
(
fun
s
->
opt_driver
:=
s
::!
opt_driver
)
,
" same as -D"
;
"--recursive"
,
Arg
.
Unit
(
fun
()
->
opt_recurs
:=
true
)
,
" perform recursive extraction "
;
"-o"
,
Arg
.
String
(
fun
s
->
opt_output
:=
Some
s
)
,
"<dir> print the selected goals to separate files in <dir>"
;
"--output"
,
Arg
.
String
(
fun
s
->
opt_output
:=
Some
s
)
,
...
...
@@ -100,6 +103,8 @@ let opt_driver =
eprintf
"%a@."
Exn_printer
.
exn_printer
e
;
exit
1
let
opt_recurs
=
!
opt_recurs
let
extract_to
?
fname
m
=
let
(
fg
,
pargs
,
pr
)
=
Pdriver
.
lookup_printer
opt_driver
in
let
file
=
Filename
.
concat
opt_output
(
fg
?
fname
m
)
in
...
...
@@ -113,7 +118,7 @@ let extract_to ?fname m =
let
fmt
=
formatter_of_out_channel
cout
in
let
tname
=
m
.
mod_theory
.
Theory
.
th_name
.
Ident
.
id_string
in
Debug
.
dprintf
Pdriver
.
debug
"extract module %s to file %s@."
tname
file
;
pr
?
old
pargs
fmt
m
;
pr
?
old
?
fname
pargs
fmt
m
;
close_out
cout
let
extract_to
=
...
...
@@ -129,14 +134,13 @@ let rec use_iter f l =
List
.
iter
(
function
Uuse
t
->
f
t
|
Uscope
(
_
,_,
l
)
->
use_iter
f
l
|
_
->
()
)
l
let
rec
do_extract_module
?
fname
m
=
let
_
extract_use
m'
=
let
extract_use
m'
=
let
fname
=
if
m'
.
mod_theory
.
Theory
.
th_path
=
[]
then
fname
else
None
in
do_extract_module
?
fname
m'
in
(* for now, do not do a recursive extraction *)
(* use_iter extract_use m.mod_units; *)
if
opt_recurs
then
use_iter
extract_use
m
.
mod_units
;
extract_to
?
fname
m
let
do_global_extract
(
_
,
p
,
t
)
=
...
...
@@ -144,7 +148,6 @@ let do_global_extract (_,p,t) =
let
m
=
read_module
env
p
t
in
do_extract_module
m
let
do_extract_module_from
fname
mm
(
tname
,_,
t
)
=
try
let
m
=
Mstr
.
find
t
mm
in
do_extract_module
~
fname
m
...
...
theories/int.why
View file @
c1012422
...
...
@@ -10,8 +10,8 @@ theories for classical functions.
theory Int
constant zero : int = 0
constant one : int = 1
let
constant zero : int = 0
let
constant one : int = 1
val (=) (x y : int) : bool ensures { result <-> x = y }
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment