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
119
Issues
119
List
Boards
Labels
Service Desk
Milestones
Merge Requests
16
Merge Requests
16
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
1c7d6a15
Commit
1c7d6a15
authored
Aug 26, 2010
by
Andrei Paskevich
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
add Debug.stack_trace flag and Trans.apply_named call
parent
2120ce42
Changes
7
Hide whitespace changes
Inline
Side-by-side
Showing
7 changed files
with
21 additions
and
24 deletions
+21
-24
src/core/trans.ml
src/core/trans.ml
+9
-0
src/core/trans.mli
src/core/trans.mli
+2
-0
src/driver/driver.ml
src/driver/driver.ml
+1
-7
src/main.ml
src/main.ml
+3
-13
src/parser/lexer.mll
src/parser/lexer.mll
+3
-4
src/util/debug.ml
src/util/debug.ml
+2
-0
src/util/debug.mli
src/util/debug.mli
+1
-0
No files found.
src/core/trans.ml
View file @
1c7d6a15
...
...
@@ -40,8 +40,14 @@ let singleton f x = [f x]
let
compose
f
g
x
=
g
(
f
x
)
let
compose_l
f
g
x
=
list_apply
g
(
f
x
)
exception
TransFailure
of
(
string
*
exn
)
let
apply
f
x
=
f
x
let
apply_named
s
f
x
=
try
apply
f
x
with
|
e
when
not
(
Debug
.
test_flag
Debug
.
stack_trace
)
->
raise
(
TransFailure
(
s
,
e
))
module
Wtask
=
Hashweak
.
Make
(
struct
type
t
=
task_hd
let
tag
t
=
t
.
task_tag
...
...
@@ -213,5 +219,8 @@ let () = Exn_printer.register (fun fmt exn -> match exn with
Format
.
fprintf
fmt
"Transformation '%s' is already registered"
s
|
UnknownTrans
s
->
Format
.
fprintf
fmt
"Unknown transformation '%s'"
s
|
TransFailure
(
s
,
e
)
->
Format
.
fprintf
fmt
"Failure in transformation %s@
\n
%a"
s
Exn_printer
.
exn_printer
e
|
e
->
raise
e
)
src/core/trans.mli
View file @
1c7d6a15
...
...
@@ -95,3 +95,5 @@ val lookup_transform_l : string -> Env.env -> task tlist
val
list_transforms
:
unit
->
string
list
val
list_transforms_l
:
unit
->
string
list
val
apply_named
:
string
->
'
a
trans
->
(
task
->
'
a
)
src/driver/driver.ml
View file @
1c7d6a15
...
...
@@ -209,7 +209,6 @@ let call_on_buffer ~command ?timelimit ?memlimit drv buffer =
(** print'n'prove *)
exception
NoPrinter
exception
TransFailure
of
(
string
*
exn
)
let
update_task
drv
task
=
let
task
,
goal
=
match
task
with
...
...
@@ -240,8 +239,6 @@ let update_task drv task =
add_tdecl
task
goal
let
print_task
drv
fmt
task
=
(* TODO: wrong debug flag, should use one in Trans *)
let
debug
=
Debug
.
test_flag
Call_provers
.
debug
in
let
p
=
match
drv
.
drv_printer
with
|
None
->
raise
NoPrinter
|
Some
p
->
p
...
...
@@ -253,8 +250,7 @@ let print_task drv fmt task =
let
transl
=
List
.
map
lookup_transform
drv
.
drv_transform
in
let
apply
task
(
t
,
tr
)
=
(* Format.printf "@\n@\n[%f] %s@." (Sys.time ()) t; *)
try
Trans
.
apply
tr
task
with
e
when
not
debug
->
raise
(
TransFailure
(
t
,
e
))
Trans
.
apply_named
t
tr
task
in
(*Format.printf "@\n@\nTASK";*)
let
task
=
update_task
drv
task
in
...
...
@@ -279,8 +275,6 @@ let () = Exn_printer.register (fun fmt exn -> match exn with
"Plugins are not supported, recomplie Why"
|
Duplicate
s
->
Format
.
fprintf
fmt
"Duplicate %s specification"
s
|
TransFailure
(
s
,
e
)
->
Format
.
fprintf
fmt
"Failure in transformation %s@
\n
%a"
s
Exn_printer
.
exn_printer
e
|
UnknownType
(
thl
,
idl
)
->
Format
.
fprintf
fmt
"Unknown type symbol %s"
(
string_of_qualid
thl
idl
)
|
UnknownLogic
(
thl
,
idl
)
->
Format
.
fprintf
fmt
...
...
src/main.ml
View file @
1c7d6a15
...
...
@@ -325,9 +325,6 @@ let memlimit = match !opt_memlimit with
|
Some
i
when
i
<=
0
->
0
|
Some
i
->
i
(* TODO: move every debugging output to the proper module *)
let
debug
=
!
opt_debug_all
let
print_th_namespace
fmt
th
=
Pretty
.
print_namespace
fmt
th
.
th_name
.
Ident
.
id_string
th
...
...
@@ -366,15 +363,8 @@ let do_tasks env drv fname tname th trans task =
in
let
transl
=
List
.
fold_left
lookup
[]
trans
in
let
apply
tasks
(
s
,
tr
)
=
try
if
debug
then
Format
.
eprintf
"apply transformation %s@."
s
;
let
l
=
List
.
fold_left
(
fun
acc
task
->
List
.
rev_append
(
Trans
.
apply
tr
task
)
acc
)
[]
tasks
in
List
.
rev
l
(* In order to keep the order for 1-1 transformation *)
with
e
when
not
debug
->
Format
.
eprintf
"failure in transformation %s@."
s
;
raise
e
List
.
rev
(
List
.
fold_left
(
fun
acc
task
->
List
.
rev_append
(
Trans
.
apply_named
s
tr
task
)
acc
)
[]
tasks
)
in
let
tasks
=
List
.
fold_left
apply
[
task
]
transl
in
List
.
iter
(
do_task
drv
fname
tname
th
)
tasks
...
...
@@ -453,7 +443,7 @@ let () =
let
env
=
Env
.
create_env
(
Lexer
.
retrieve
!
opt_loadpath
)
in
let
drv
=
Util
.
option_map
(
load_driver
env
)
!
opt_driver
in
Queue
.
iter
(
do_input
env
drv
)
opt_queue
with
e
when
not
debug
->
with
e
when
not
(
Debug
.
test_flag
Debug
.
stack_trace
)
->
eprintf
"%a@."
Exn_printer
.
exn_printer
e
;
exit
1
...
...
src/parser/lexer.mll
View file @
1c7d6a15
...
...
@@ -224,7 +224,7 @@ and comment = parse
|
newline
{
newline
lexbuf
;
comment
lexbuf
}
|
eof
{
raise
(
Loc
.
Located
(
!
comment_start_loc
,
UnterminatedComment
))
}
{
raise
(
Loc
.
Located
(
!
comment_start_loc
,
UnterminatedComment
))
}
|
_
{
comment
lexbuf
}
...
...
@@ -244,9 +244,8 @@ and string = parse
{
let
with_location
f
lb
=
try
f
lb
with
if
Debug
.
test_flag
Debug
.
stack_trace
then
f
lb
else
try
f
lb
with
|
Loc
.
Located
_
as
e
->
raise
e
|
e
->
raise
(
Loc
.
Located
(
loc
lb
,
e
))
...
...
src/util/debug.ml
View file @
1c7d6a15
...
...
@@ -46,3 +46,5 @@ let () = Exn_printer.register (fun fmt e -> match e with
|
UnknownFlag
s
->
Format
.
fprintf
fmt
"unknown debug flag `%s'@."
s
|
_
->
raise
e
)
let
stack_trace
=
register_flag
"stack_trace"
src/util/debug.mli
View file @
1c7d6a15
...
...
@@ -29,3 +29,4 @@ val toggle_flag : flag -> unit
val
test_flag
:
flag
->
bool
val
stack_trace
:
flag
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