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
121
Issues
121
List
Boards
Labels
Service Desk
Milestones
Merge Requests
14
Merge Requests
14
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
bea2bd78
Commit
bea2bd78
authored
Oct 10, 2017
by
Mário Pereira
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Extraction: nicer printing of functors modules
parent
d754ddee
Changes
5
Hide whitespace changes
Inline
Side-by-side
Showing
5 changed files
with
43 additions
and
17 deletions
+43
-17
drivers/ocaml64.drv
drivers/ocaml64.drv
+11
-1
src/mlw/compile.ml
src/mlw/compile.ml
+4
-10
src/mlw/ocaml_printer.ml
src/mlw/ocaml_printer.ml
+10
-6
src/mlw/ocaml_printer.mli
src/mlw/ocaml_printer.mli
+7
-0
src/tools/why3extract.ml
src/tools/why3extract.ml
+11
-0
No files found.
drivers/ocaml64.drv
View file @
bea2bd78
...
...
@@ -238,6 +238,17 @@ module mach.int.Random63
syntax val random_int63 "Random.int %1"
end
module mach.int.State63
(* the most appropriate way to do this would be to have
something similar to [remove] from smt drivers:
remove val create *)
syntax val create "SHOULD_NOT_BE_HERE"
syntax val init "SHOULD_NOT_BE_HERE"
syntax val self_init "SHOULD_NOT_BE_HERE"
syntax val random_bool "SHOULD_NOT_BE_HERE"
syntax val random_int63 "SHOULD_NOT_BE_HERE"
end
module mach.peano.Peano
syntax type t "int"
syntax val to_int "Z.of_int %1"
...
...
@@ -360,4 +371,3 @@ module ocaml.Pervasives
syntax val succ "succ %1"
syntax val pred "pred %1"
end
src/mlw/compile.ml
View file @
bea2bd78
...
...
@@ -723,8 +723,10 @@ module Translate = struct
let
args
=
params
cty
.
cty_args
in
let
res
=
mlty_of_ity
cty
.
cty_mask
cty
.
cty_result
in
[
Mltree
.
Dlet
(
Mltree
.
Lany
(
rs
,
res
,
args
))]
|
PDlet
(
LDsym
(
_
,
{
c_node
=
Cfun
e
}))
when
is_val
e
.
e_node
->
[]
|
PDlet
(
LDsym
({
rs_cty
=
cty
}
as
rs
,
{
c_node
=
Cfun
e
}))
when
is_val
e
.
e_node
->
(* zero argument functions *)
let
res
=
mlty_of_ity
cty
.
cty_mask
cty
.
cty_result
in
[
Mltree
.
Dlet
(
Mltree
.
Lany
(
rs
,
res
,
[]
))]
|
PDlet
(
LDsym
({
rs_cty
=
cty
}
as
rs
,
{
c_node
=
Cfun
e
}))
->
let
args
=
params
cty
.
cty_args
in
let
res
=
mlty_of_ity
cty
.
cty_mask
cty
.
cty_result
in
...
...
@@ -816,14 +818,6 @@ module Translate = struct
Mltree
.
mod_known
=
mod_known
;
}
(* let () = Exn_printer.register (fun fmt e -> match e with *)
(* | ExtractionAny -> *)
(* Format.fprintf fmt "Cannot extract an undefined node" *)
(* | ExtractionVal rs -> *)
(* Format.fprintf fmt "Function %a cannot be extracted" *)
(* print_rs rs *)
(* | _ -> raise e) *)
end
(** Some transformations *)
...
...
src/mlw/ocaml_printer.ml
View file @
bea2bd78
...
...
@@ -277,7 +277,7 @@ module Print = struct
(* here [rs] refers to a [val] declaration *)
match
query_syntax
info
.
info_convert
rs
.
rs_name
,
query_syntax
info
.
info_syn
rs
.
rs_name
with
|
None
,
None
when
info
.
info_flat
->
|
None
,
None
(* when info.info_flat *)
->
Loc
.
errorm
?
loc
"Function %a cannot be extracted"
Expr
.
print_rs
rs
|
_
->
()
...
...
@@ -318,7 +318,7 @@ module Print = struct
else
fprintf
fmt
"%s"
s
|
_
->
assert
false
in
syntax_arguments
s
print_constant
fmt
pvl
|
_
,
Some
s
,
_
->
|
_
,
Some
s
,
_
(* when is_local_id info rs.rs_name *)
->
syntax_arguments
s
(
print_expr
~
paren
:
true
info
)
fmt
pvl
;
|
_
,
None
,
tl
when
is_rs_tuple
rs
->
fprintf
fmt
"@[(%a)@]"
...
...
@@ -344,7 +344,7 @@ module Print = struct
end
|
_
,
None
,
[]
->
(
print_lident
info
)
fmt
rs
.
rs_name
|
_
,
None
,
tl
->
|
_
,
_
,
tl
->
(* FIXME? when is in driver but is not a local id *)
fprintf
fmt
"@[<hov 2>%a %a@]"
(
print_lident
info
)
rs
.
rs_name
(
print_apply_args
info
)
(
tl
,
rs
.
rs_cty
.
cty_args
)
...
...
@@ -395,6 +395,10 @@ module Print = struct
List
.
iter
(
fun
fd
->
Hrs
.
replace
ht_rs
fd
.
rec_rsym
fd
.
rec_sym
)
rdef
;
print_list_next
newline
print_one
fmt
rdef
;
List
.
iter
(
fun
fd
->
Hrs
.
remove
ht_rs
fd
.
rec_rsym
)
rdef
|
Lany
(
rs
,
res
,
[]
)
when
functor_arg
->
fprintf
fmt
"@[<hov 2>val %a : %a@]"
(
print_lident
info
)
rs
.
rs_name
(
print_ty
info
)
res
;
|
Lany
(
rs
,
res
,
args
)
when
functor_arg
->
let
print_ty_arg
info
fmt
(
_
,
ty
,
_
)
=
fprintf
fmt
"@[%a@]"
(
print_ty
info
)
ty
in
...
...
@@ -600,18 +604,18 @@ module Print = struct
|
Dmodule
(
s
,
dl
)
->
let
args
,
dl
=
extract_functor_args
info
dl
in
let
info
=
{
info
with
info_current_ph
=
s
::
info
.
info_current_ph
}
in
fprintf
fmt
"@[@[<hov 2>module %s%a@ =@
struct@ %a@]@ end@]
"
s
fprintf
fmt
"@[@[<hov 2>module %s%a@ =@
]@
\n
@[<hov 2>struct@ %a@]@ end
"
s
(
print_functor_args
info
)
args
(
print_list
newline2
(
print_decl
info
))
dl
and
print_functor_args
info
fmt
args
=
let
print_sig
info
fmt
dl
=
fprintf
fmt
"sig@ %a@ end"
(
print_list
spac
e
(
print_decl
info
~
functor_arg
:
true
))
dl
in
(
print_list
newlin
e
(
print_decl
info
~
functor_arg
:
true
))
dl
in
let
print_pair
fmt
(
s
,
dl
)
=
let
info
=
{
info
with
info_current_ph
=
s
::
info
.
info_current_ph
}
in
fprintf
fmt
"(%s:@ %a)"
s
(
print_sig
info
)
dl
in
fprintf
fmt
"
@[%a@]
"
(
print_list
space
print_pair
)
args
fprintf
fmt
"
%a
"
(
print_list
space
print_pair
)
args
let
print_decl
info
fmt
decl
=
(* avoids printing the same decl for mutually recursive decls *)
...
...
src/mlw/ocaml_printer.mli
0 → 100644
View file @
bea2bd78
module
Print
:
sig
val
optional_arg
:
Ident
.
label
val
named_arg
:
Ident
.
label
val
ocaml_remove
:
Ident
.
label
end
src/tools/why3extract.ml
View file @
bea2bd78
...
...
@@ -135,6 +135,14 @@ let get_cout_old ?fname fg m = match opt_output with
Some
(
open_in
backup
)
end
else
None
in
open_out
file
,
old
let
print_preludes
=
let
ht
=
Hstr
.
create
8
in
let
add
l
s
=
if
Hstr
.
mem
ht
s
then
l
else
(
Hstr
.
add
ht
s
()
;
s
::
l
)
in
fun
id_th
fmt
pm
->
let
th_pm
=
Ident
.
Mid
.
find_def
[]
id_th
pm
in
let
l
=
List
.
fold_left
add
[]
th_pm
in
Printer
.
print_prelude
fmt
l
let
print_mdecls
?
fname
m
mdecls
=
let
(
fg
,
pargs
,
pr
)
=
Pdriver
.
lookup_printer
opt_driver
in
let
test_decl_not_driver
decl
=
...
...
@@ -145,6 +153,9 @@ let print_mdecls ?fname m mdecls =
if
List
.
exists
test_decl_not_driver
mdecls
then
begin
let
cout
,
old
=
get_cout_old
fg
m
?
fname
in
let
fmt
=
formatter_of_out_channel
cout
in
(* print driver prelude *)
let
pm
=
pargs
.
Pdriver
.
thprelude
in
print_preludes
m
.
mod_theory
.
Theory
.
th_name
fmt
pm
;
let
flat
=
opt_modu_flat
=
Flat
in
let
pr_decl
fmt
d
=
fprintf
fmt
"%a"
(
pr
pargs
?
old
?
fname
~
flat
m
)
d
in
Pp
.
print_list
Pp
.
newline
pr_decl
fmt
mdecls
;
...
...
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