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
9ceb1577
Commit
9ceb1577
authored
Mar 04, 2011
by
MARCHE Claude
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
file locations: a lot of cleaning
parent
404ecebf
Changes
8
Hide whitespace changes
Inline
Side-by-side
Showing
8 changed files
with
157 additions
and
213 deletions
+157
-213
src/core/ident.ml
src/core/ident.ml
+3
-0
src/driver/driver_lexer.mll
src/driver/driver_lexer.mll
+1
-1
src/driver/driver_parser.mly
src/driver/driver_parser.mly
+2
-2
src/ide/gmain.ml
src/ide/gmain.ml
+52
-51
src/parser/lexer.mll
src/parser/lexer.mll
+1
-1
src/parser/parser.pre.mly
src/parser/parser.pre.mly
+62
-69
src/util/loc.ml
src/util/loc.ml
+24
-62
src/util/loc.mli
src/util/loc.mli
+12
-27
No files found.
src/core/ident.ml
View file @
9ceb1577
...
...
@@ -74,6 +74,7 @@ let end_regexp = Str.regexp "end:\\([0-9]+\\)"
let
id_fresh
?
(
labels
=
[]
)
nm
=
create_ident
nm
Fresh
labels
let
id_user
?
(
labels
=
[]
)
nm
loc
=
(*
let (f,li,b,e) = Loc.extract loc in
let f = ref f in
let li = ref li in
...
...
@@ -101,6 +102,8 @@ let id_user ?(labels = []) nm loc =
{Lexing.pos_fname = !f; Lexing.pos_lnum = !li;
Lexing.pos_bol = 0; Lexing.pos_cnum = !e})
in
*)
let
l
=
labels
in
create_ident
nm
(
User
loc
)
l
let
id_derive
?
(
labels
=
[]
)
nm
id
=
create_ident
nm
(
Derived
id
)
labels
...
...
src/driver/driver_lexer.mll
View file @
9ceb1577
...
...
@@ -98,7 +98,7 @@ rule token = parse
{
raise
(
IllegalCharacter
c
)
}
{
let
loc
lb
=
(
lexeme_start_p
lb
,
lexeme_end_p
lb
)
let
loc
lb
=
Loc
.
extract
(
lexeme_start_p
lb
,
lexeme_end_p
lb
)
let
with_location
f
lb
=
try
f
lb
with
e
->
raise
(
Loc
.
Located
(
loc
lb
,
e
))
...
...
src/driver/driver_parser.mly
View file @
9ceb1577
...
...
@@ -20,8 +20,8 @@
%
{
open
Driver_ast
open
Parsing
let
loc
()
=
(
symbol_start_pos
()
,
symbol_end_pos
()
)
let
loc_i
i
=
(
rhs_start_pos
i
,
rhs_end_pos
i
)
let
loc
()
=
Loc
.
extract
(
symbol_start_pos
()
,
symbol_end_pos
()
)
let
loc_i
i
=
Loc
.
extract
(
rhs_start_pos
i
,
rhs_end_pos
i
)
let
infix
s
=
"infix "
^
s
let
prefix
s
=
"prefix "
^
s
%
}
...
...
src/ide/gmain.ml
View file @
9ceb1577
...
...
@@ -204,14 +204,14 @@ let () =
let
read_file
fn
=
let
fn
=
Filename
.
concat
project_dir
fn
in
let
fn
=
Filename
.
concat
project_dir
fn
in
let
theories
=
Env
.
read_file
gconfig
.
env
fn
in
let
theories
=
Theory
.
Mnm
.
fold
(
fun
name
th
acc
->
match
th
.
Theory
.
th_name
.
Ident
.
id_origin
with
|
Ident
.
User
l
->
(
Loc
.
extract
l
,
name
,
th
)
::
acc
|
_
->
(
Loc
.
dummy_
floc
,
name
,
th
)
::
acc
)
|
Ident
.
User
l
->
(
l
,
name
,
th
)
::
acc
|
_
->
(
Loc
.
dummy_
position
,
name
,
th
)
::
acc
)
theories
[]
in
let
theories
=
List
.
sort
...
...
@@ -554,21 +554,21 @@ module Helpers = struct
|
Running
->
!
image_running
|
InternalFailure
_
->
!
image_failure
|
Done
r
->
match
r
.
Call_provers
.
pr_answer
with
|
Call_provers
.
Valid
->
if
obsolete
then
!
image_valid
else
!
image_valid_obs
|
Call_provers
.
Invalid
->
if
obsolete
then
!
image_invalid
else
!
image_invalid_obs
|
Call_provers
.
Timeout
->
if
obsolete
then
!
image_timeout
else
!
image_timeout_obs
|
Call_provers
.
Unknown
_
->
if
obsolete
then
!
image_unknown
else
!
image_unknown_obs
|
Call_provers
.
Failure
_
->
if
obsolete
then
!
image_failure
else
!
image_failure_obs
|
Call_provers
.
HighFailure
->
if
obsolete
then
!
image_failure
else
!
image_failure_obs
|
Call_provers
.
Valid
->
if
obsolete
then
!
image_valid
_obs
else
!
image_valid
|
Call_provers
.
Invalid
->
if
obsolete
then
!
image_invalid
_obs
else
!
image_invalid
|
Call_provers
.
Timeout
->
if
obsolete
then
!
image_timeout
_obs
else
!
image_timeout
|
Call_provers
.
Unknown
_
->
if
obsolete
then
!
image_unknown
_obs
else
!
image_unknown
|
Call_provers
.
Failure
_
->
if
obsolete
then
!
image_failure
_obs
else
!
image_failure
|
Call_provers
.
HighFailure
->
if
obsolete
then
!
image_failure
_obs
else
!
image_failure
let
set_row_status
b
row
=
if
b
then
if
b
then
begin
goals_view
#
collapse_row
(
goals_model
#
get_path
row
);
goals_model
#
set
~
row
~
column
:
status_column
!
image_yes
;
...
...
@@ -600,13 +600,13 @@ module Helpers = struct
end
let
rec
check_goal_proved
g
=
let
b1
=
Hashtbl
.
fold
(
fun
_
a
acc
->
acc
||
let
b1
=
Hashtbl
.
fold
(
fun
_
a
acc
->
acc
||
match
a
.
proof_state
with
|
Done
{
Call_provers
.
pr_answer
=
Call_provers
.
Valid
}
->
true
|
_
->
false
)
g
.
external_proofs
false
in
let
b
=
Hashtbl
.
fold
let
b
=
Hashtbl
.
fold
(
fun
_
t
acc
->
acc
||
t
.
transf_proved
)
g
.
transformations
b1
in
if
g
.
proved
<>
b
then
...
...
@@ -626,7 +626,7 @@ module Helpers = struct
set_row_status
b
t
.
transf_row
;
check_goal_proved
t
.
parent_goal
end
(* deprecated *)
let
set_file_verified
f
=
...
...
@@ -678,9 +678,9 @@ module Helpers = struct
let
row
=
a
.
proof_row
in
goals_model
#
set
~
row
~
column
:
status_column
(
image_of_result
~
obsolete
res
);
let
t
=
match
res
with
|
Done
{
Call_provers
.
pr_time
=
time
}
->
|
Done
{
Call_provers
.
pr_time
=
time
}
->
Format
.
sprintf
"%.2f"
time
|
_
->
""
in
...
...
@@ -859,7 +859,7 @@ let trans_list =
let
trans_of_name
=
let
h
=
Hashtbl
.
create
13
in
List
.
iter
List
.
iter
(
fun
n
->
Hashtbl
.
add
h
n
(
lookup_trans
n
))
trans_list
;
Hashtbl
.
find
h
...
...
@@ -873,20 +873,20 @@ exception Not_applicable
let
apply_trans
t
task
=
match
t
with
|
Trans_one
t
->
|
Trans_one
t
->
let
t'
=
Trans
.
apply
t
task
in
if
task
==
t'
then
raise
Not_applicable
;
[
t'
]
|
Trans_list
t
->
|
Trans_list
t
->
match
Trans
.
apply
t
task
with
|
[
t'
]
as
l
->
if
task
==
t'
then
raise
Not_applicable
;
l
|
l
->
l
let
apply_transformation
~
callback
t
task
=
match
t
with
|
Trans_one
t
->
|
Trans_one
t
->
let
callback
t
=
callback
[
t
]
in
Scheduler
.
apply_transformation
~
callback
t
task
|
Trans_list
t
->
|
Trans_list
t
->
Scheduler
.
apply_transformation_l
~
callback
t
task
...
...
@@ -916,8 +916,8 @@ let rec reimport_any_goal parent gid gname t db_goal goal_obsolete =
}
in
let
(
_pa
:
Model
.
proof_attempt
)
=
Helpers
.
add_external_proof_row
~
obsolete
~
edit
goal
p
a
(
Scheduler
.
Done
r
)
Helpers
.
add_external_proof_row
~
obsolete
~
edit
goal
p
a
(
Scheduler
.
Done
r
)
in
((
*
something
TODO
?*
))
with
Not_found
->
...
...
@@ -1158,11 +1158,11 @@ let redo_external_proof q g a =
a.Model.proof_state <- result;
*)
Helpers
.
set_proof_state
~
obsolete
:
false
a
result
(*time*)
;
let
db_res
,
time
=
let
db_res
,
time
=
match
result
with
|
Scheduler
.
Scheduled
|
Scheduler
.
Running
->
|
Scheduler
.
Scheduled
|
Scheduler
.
Running
->
Db
.
Undone
,
0
.
0
|
Scheduler
.
InternalFailure
_
->
|
Scheduler
.
InternalFailure
_
->
Db
.
Done
Call_provers
.
HighFailure
,
0
.
0
|
Scheduler
.
Done
r
->
if
r
.
Call_provers
.
pr_answer
=
Call_provers
.
Valid
then
...
...
@@ -1246,19 +1246,19 @@ let prover_on_selected_goals pr =
let
transformation_on_goal
g
trans_name
trans
=
if
not
g
.
Model
.
proved
then
let
callback
subgoals
=
ignore
(
Thread
.
create
ignore
(
Thread
.
create
(
fun
subgoals
->
let
b
=
match
subgoals
with
|
[
task
]
->
|
[
task
]
->
let
s1
=
task_checksum
g
.
Model
.
task
in
let
s2
=
task_checksum
task
in
(*
eprintf "Transformation returned only one task. sum before = %s, sum after = %s@." (task_checksum g.Model.task) (task_checksum task);
eprintf "addresses: %x %x@." (Obj.magic g.Model.task) (Obj.magic task);
*)
s1
<>
s2
s1
<>
s2
(* task != g.Model.task *)
|
_
->
true
in
...
...
@@ -1269,27 +1269,27 @@ let transformation_on_goal g trans_name trans =
(
GtkThread
.
sync
Db
.
add_transformation
)
g
.
Model
.
goal_db
transf_id
in
let
tr
=
(
GtkThread
.
sync
Helpers
.
add_transformation_row
)
g
db_transf
trans_name
let
tr
=
(
GtkThread
.
sync
Helpers
.
add_transformation_row
)
g
db_transf
trans_name
in
let
goal_name
=
g
.
Model
.
goal_name
in
let
fold
=
let
fold
=
fun
(
acc
,
count
)
subtask
->
let
_id
=
(
Task
.
task_goal
subtask
)
.
Decl
.
pr_name
in
let
subgoal_name
=
goal_name
^
"."
^
(
string_of_int
count
)
in
let
sum
=
task_checksum
subtask
in
let
subtask_db
=
Db
.
add_subgoal
db_transf
subgoal_name
sum
let
subtask_db
=
Db
.
add_subgoal
db_transf
subgoal_name
sum
in
let
goal
=
Helpers
.
add_goal_row
(
Model
.
Transf
tr
)
Helpers
.
add_goal_row
(
Model
.
Transf
tr
)
subgoal_name
None
subtask
subtask_db
in
(
goal
::
acc
,
count
+
1
)
(
goal
::
acc
,
count
+
1
)
in
let
goals
,_
=
let
goals
,_
=
List
.
fold_left
(
GtkThread
.
sync
fold
)
([]
,
1
)
subgoals
in
tr
.
Model
.
subgoals
<-
List
.
rev
goals
;
...
...
@@ -1306,7 +1306,7 @@ let rec split_goal_or_children g =
if
not
g
.
Model
.
proved
then
begin
let
r
=
ref
true
in
Hashtbl
.
iter
Hashtbl
.
iter
(
fun
_
t
->
r
:=
false
;
List
.
iter
split_goal_or_children
...
...
@@ -1318,7 +1318,7 @@ let rec inline_goal_or_children g =
if
not
g
.
Model
.
proved
then
begin
let
r
=
ref
true
in
Hashtbl
.
iter
Hashtbl
.
iter
(
fun
_
t
->
r
:=
false
;
List
.
iter
inline_goal_or_children
...
...
@@ -1780,7 +1780,7 @@ let color_loc (v:GSourceView2.source_view) l b e =
let
scroll_to_id
id
=
match
id
.
Ident
.
id_origin
with
|
Ident
.
User
loc
->
let
(
f
,
l
,
b
,
e
)
=
Loc
.
extrac
t
loc
in
let
(
f
,
l
,
b
,
e
)
=
Loc
.
ge
t
loc
in
if
f
<>
!
current_file
then
begin
source_view
#
source_buffer
#
set_text
(
source_text
f
);
...
...
@@ -1799,9 +1799,10 @@ let scroll_to_id id =
set_current_file
""
let
color_label
=
function
|
_
,
Some
loc
when
(
fst
loc
)
.
Lexing
.
pos_fname
=
!
current_file
->
let
_
,
l
,
b
,
e
=
Loc
.
extract
loc
in
color_loc
source_view
l
b
e
|
_
,
Some
loc
->
let
f
,
l
,
b
,
e
=
Loc
.
get
loc
in
if
f
=
!
current_file
then
color_loc
source_view
l
b
e
|
_
->
()
...
...
@@ -1994,7 +1995,7 @@ let remove_transf t =
let
g
=
t
.
Model
.
parent_goal
in
Hashtbl
.
remove
g
.
Model
.
transformations
"split"
(* hack !! *)
;
Helpers
.
check_goal_proved
g
let
confirm_remove_row
r
=
let
row
=
filter_model
#
get_iter
r
in
...
...
src/parser/lexer.mll
View file @
9ceb1577
...
...
@@ -136,7 +136,7 @@
let
n
=
String
.
length
s
in
if
n
>
0
&&
s
.
[
0
]
=
'
+
'
then
String
.
sub
s
1
(
n
-
1
)
else
s
let
loc
lb
=
(
lexeme_start_p
lb
,
lexeme_end_p
lb
)
let
loc
lb
=
Loc
.
extract
(
lexeme_start_p
lb
,
lexeme_end_p
lb
)
}
...
...
src/parser/parser.pre.mly
View file @
9ceb1577
...
...
@@ -54,20 +54,24 @@
open
Parsing
let
loc
()
=
(
symbol_start_pos
()
,
symbol_end_pos
()
)
let
floc
()
=
Loc
.
extract
(
loc
()
)
let
loc_i
i
=
(
rhs_start_pos
i
,
rhs_end_pos
i
)
let
floc_i
i
=
Loc
.
extract
(
loc_i
i
)
let
loc_ij
i
j
=
(
rhs_start_pos
i
,
rhs_end_pos
j
)
let
floc_ij
i
j
=
Loc
.
extract
(
loc_ij
i
j
)
let
mk_ppl
loc
d
=
{
pp_loc
=
loc
;
pp_desc
=
d
}
let
mk_pp
d
=
mk_ppl
(
loc
()
)
d
let
mk_pp_i
i
d
=
mk_ppl
(
loc_i
i
)
d
let
mk_pp
d
=
mk_ppl
(
f
loc
()
)
d
let
mk_pp_i
i
d
=
mk_ppl
(
f
loc_i
i
)
d
let
mk_pat
p
=
{
pat_loc
=
loc
()
;
pat_desc
=
p
}
let
mk_pat
p
=
{
pat_loc
=
f
loc
()
;
pat_desc
=
p
}
let
infix_ppl
loc
a
i
b
=
mk_ppl
loc
(
PPbinop
(
a
,
i
,
b
))
let
infix_pp
a
i
b
=
infix_ppl
(
loc
()
)
a
i
b
let
infix_pp
a
i
b
=
infix_ppl
(
f
loc
()
)
a
i
b
let
prefix_ppl
loc
p
a
=
mk_ppl
loc
(
PPunop
(
p
,
a
))
let
prefix_pp
p
a
=
prefix_ppl
(
loc
()
)
p
a
let
prefix_pp
p
a
=
prefix_ppl
(
f
loc
()
)
p
a
let
infix
s
=
"infix "
^
s
let
prefix
s
=
"prefix "
^
s
...
...
@@ -77,37 +81,26 @@
let
add_lab
id
l
=
{
id
with
id_lab
=
l
}
let
user_loc
fname
lnum
bol
cnum1
cnum2
=
let
pos
=
{
Lexing
.
pos_fname
=
fname
;
Lexing
.
pos_lnum
=
lnum
;
Lexing
.
pos_bol
=
bol
;
Lexing
.
pos_cnum
=
cnum1
}
in
pos
,
{
pos
with
Lexing
.
pos_cnum
=
cnum2
}
let
()
=
Exn_printer
.
register
(
fun
fmt
exn
->
match
exn
with
|
Parsing
.
Parse_error
->
Format
.
fprintf
fmt
"syntax error"
|
_
->
raise
exn
)
let
mk_expr
d
=
{
expr_loc
=
loc
()
;
expr_desc
=
d
}
let
mk_expr_i
i
d
=
{
expr_loc
=
loc_i
i
;
expr_desc
=
d
}
let
mk_expr
d
=
{
expr_loc
=
f
loc
()
;
expr_desc
=
d
}
let
mk_expr_i
i
d
=
{
expr_loc
=
f
loc_i
i
;
expr_desc
=
d
}
let
cast_body
c
((
p
,
e
,
q
)
as
t
)
=
match
c
with
|
None
->
t
|
Some
pt
->
p
,
{
e
with
expr_desc
=
Ecast
(
e
,
pt
)
}
,
q
let
join
(
b
,_
)
(
_
,
e
)
=
(
b
,
e
)
let
rec
mk_apply
f
=
function
|
[]
->
assert
false
|
[
a
]
->
Eapply
(
f
,
a
)
|
a
::
l
->
let
loc
=
join
f
.
expr_loc
a
.
expr_loc
in
let
loc
=
Loc
.
join
f
.
expr_loc
a
.
expr_loc
in
mk_apply
{
expr_loc
=
loc
;
expr_desc
=
Eapply
(
f
,
a
)
}
l
let
mk_apply_id
id
=
...
...
@@ -117,27 +110,27 @@
mk_apply
e
let
mk_misfix2
op
e1
e2
=
let
id
=
{
id
=
misfix
op
;
id_lab
=
[]
;
id_loc
=
loc_i
2
}
in
let
id
=
{
id
=
misfix
op
;
id_lab
=
[]
;
id_loc
=
f
loc_i
2
}
in
mk_expr
(
mk_apply_id
id
[
e1
;
e2
])
let
mk_misfix3
op
e1
e2
e3
=
let
id
=
{
id
=
misfix
op
;
id_lab
=
[]
;
id_loc
=
loc_i
2
}
in
let
id
=
{
id
=
misfix
op
;
id_lab
=
[]
;
id_loc
=
f
loc_i
2
}
in
mk_expr
(
mk_apply_id
id
[
e1
;
e2
;
e3
])
let
mk_infix
e1
op
e2
=
let
id
=
{
id
=
infix
op
;
id_lab
=
[]
;
id_loc
=
loc_i
2
}
in
let
id
=
{
id
=
infix
op
;
id_lab
=
[]
;
id_loc
=
f
loc_i
2
}
in
mk_expr
(
mk_apply_id
id
[
e1
;
e2
])
let
mk_prefix
op
e1
=
let
id
=
{
id
=
prefix
op
;
id_lab
=
[]
;
id_loc
=
loc_i
1
}
in
let
id
=
{
id
=
prefix
op
;
id_lab
=
[]
;
id_loc
=
f
loc_i
1
}
in
mk_expr
(
mk_apply_id
id
[
e1
])
let
exit_exn
()
=
Qident
{
id
=
"%Exit"
;
id_lab
=
[]
;
id_loc
=
loc
()
}
let
id_anonymous
()
=
{
id
=
"_"
;
id_lab
=
[]
;
id_loc
=
loc
()
}
let
id_unit
()
=
{
id
=
"unit"
;
id_lab
=
[]
;
id_loc
=
loc
()
}
let
exit_exn
()
=
Qident
{
id
=
"%Exit"
;
id_lab
=
[]
;
id_loc
=
f
loc
()
}
let
id_anonymous
()
=
{
id
=
"_"
;
id_lab
=
[]
;
id_loc
=
f
loc
()
}
let
id_unit
()
=
{
id
=
"unit"
;
id_lab
=
[]
;
id_loc
=
f
loc
()
}
let
ty_unit
()
=
Tpure
(
PPTtyapp
([]
,
Qident
(
id_unit
()
)))
let
id_lt_nat
()
=
Qident
{
id
=
"lt_nat"
;
id_lab
=
[]
;
id_loc
=
loc
()
}
let
id_lt_nat
()
=
Qident
{
id
=
"lt_nat"
;
id_lab
=
[]
;
id_loc
=
f
loc
()
}
let
empty_effect
=
{
pe_reads
=
[]
;
pe_writes
=
[]
;
pe_raises
=
[]
}
...
...
@@ -272,7 +265,7 @@ new_decl:
{
let
env
=
ref_get
env_ref
in
let
lenv
=
ref_get
lenv_ref
in
ref_set
uc_ref
(
Typing
.
add_decl
env
lenv
(
ref_get
uc_ref
)
$
1
)
}
|
namespace_head
namespace_import
namespace_name
list0_decl
END
{
ref_set
uc_ref
(
Typing
.
close_namespace
(
loc
()
)
$
2
$
3
(
ref_get
uc_ref
))
}
{
ref_set
uc_ref
(
Typing
.
close_namespace
(
f
loc
()
)
$
2
$
3
(
ref_get
uc_ref
))
}
;
namespace_head
:
...
...
@@ -300,19 +293,19 @@ decl:
|
INDUCTIVE
list1_inductive_decl
{
IndDecl
$
2
}
|
AXIOM
ident
labels
COLON
lexpr
{
PropDecl
(
loc
()
,
Kaxiom
,
add_lab
$
2
$
3
,
$
5
)
}
{
PropDecl
(
f
loc
()
,
Kaxiom
,
add_lab
$
2
$
3
,
$
5
)
}
|
LEMMA
ident
labels
COLON
lexpr
{
PropDecl
(
loc
()
,
Klemma
,
add_lab
$
2
$
3
,
$
5
)
}
{
PropDecl
(
f
loc
()
,
Klemma
,
add_lab
$
2
$
3
,
$
5
)
}
|
GOAL
ident
labels
COLON
lexpr
{
PropDecl
(
loc
()
,
Kgoal
,
add_lab
$
2
$
3
,
$
5
)
}
{
PropDecl
(
f
loc
()
,
Kgoal
,
add_lab
$
2
$
3
,
$
5
)
}
|
USE
use
{
UseClone
(
loc
()
,
$
2
,
None
)
}
{
UseClone
(
f
loc
()
,
$
2
,
None
)
}
|
CLONE
use
clone_subst
{
UseClone
(
loc
()
,
$
2
,
Some
$
3
)
}
{
UseClone
(
f
loc
()
,
$
2
,
Some
$
3
)
}
|
META
ident
list1_meta_arg_sep_comma
{
Meta
(
loc
()
,
$
2
,
$
3
)
}
{
Meta
(
f
loc
()
,
$
2
,
$
3
)
}
|
META
STRING
list1_meta_arg_sep_comma
{
Meta
(
loc
()
,
mk_id
$
2
(
loc_i
2
)
,
$
3
)
}
{
Meta
(
floc
()
,
mk_id
$
2
(
f
loc_i
2
)
,
$
3
)
}
;
/*
Use
and
clone
*/
...
...
@@ -379,7 +372,7 @@ list1_type_decl:
type_decl
:
|
lident
labels
type_args
typedefn
{
{
td_loc
=
loc
()
;
td_ident
=
add_lab
$
1
$
2
;
{
{
td_loc
=
f
loc
()
;
td_ident
=
add_lab
$
1
$
2
;
td_params
=
$
3
;
td_def
=
$
4
}
}
;
...
...
@@ -407,7 +400,7 @@ list1_record_field:
record_field
:
|
opt_mutable
lident
labels
COLON
primitive_type
{
loc
()
,
$
1
,
add_lab
$
2
$
3
,
$
5
}
{
f
loc
()
,
$
1
,
add_lab
$
2
$
3
,
$
5
}
;
typecases
:
...
...
@@ -416,7 +409,7 @@ typecases:
;
typecase
:
|
uident
labels
params
{
(
loc
()
,
add_lab
$
1
$
2
,
$
3
)
}
|
uident
labels
params
{
(
f
loc
()
,
add_lab
$
1
$
2
,
$
3
)
}
;
/*
Logic
declarations
*/
...
...
@@ -428,7 +421,7 @@ list1_logic_decl:
logic_decl
:
|
lident_rich
labels
params
logic_type_option
logic_def_option
{
{
ld_loc
=
loc
()
;
ld_ident
=
add_lab
$
1
$
2
;
{
{
ld_loc
=
f
loc
()
;
ld_ident
=
add_lab
$
1
$
2
;
ld_params
=
$
3
;
ld_type
=
$
4
;
ld_def
=
$
5
}
}
;
...
...
@@ -451,7 +444,7 @@ list1_inductive_decl:
inductive_decl
:
|
lident_rich
labels
params
inddefn
{
{
in_loc
=
loc
()
;
in_ident
=
add_lab
$
1
$
2
;
{
{
in_loc
=
f
loc
()
;
in_ident
=
add_lab
$
1
$
2
;
in_params
=
$
3
;
in_def
=
$
4
}
}
;
...
...
@@ -466,7 +459,7 @@ indcases:
;
indcase
:
|
ident
labels
COLON
lexpr
{
(
loc
()
,
add_lab
$
1
$
2
,
$
4
)
}
|
ident
labels
COLON
lexpr
{
(
f
loc
()
,
add_lab
$
1
$
2
,
$
4
)
}
;
/*
Type
expressions
*/
...
...
@@ -531,19 +524,19 @@ lexpr:
|
NOT
lexpr
{
prefix_pp
PPnot
$
2
}
|
lexpr
EQUAL
lexpr
{
mk_pp
(
PPinfix
(
$
1
,
mk_id
(
infix
"="
)
(
loc_i
2
)
,
$
3
))
}
{
mk_pp
(
PPinfix
(
$
1
,
mk_id
(
infix
"="
)
(
f
loc_i
2
)
,
$
3
))
}
|
lexpr
LTGT
lexpr
{
prefix_pp
PPnot
(
mk_pp
(
PPinfix
(
$
1
,
mk_id
(
infix
"="
)
(
loc_i
2
)
,
$
3
)))
}
{
prefix_pp
PPnot
(
mk_pp
(
PPinfix
(
$
1
,
mk_id
(
infix
"="
)
(
f
loc_i
2
)
,
$
3
)))
}
|
lexpr
OP1
lexpr
{
mk_pp
(
PPinfix
(
$
1
,
mk_id
(
infix
$
2
)
(
loc_i
2
)
,
$
3
))
}
{
mk_pp
(
PPinfix
(
$
1
,
mk_id
(
infix
$
2
)
(
f
loc_i
2
)
,
$
3
))
}
|
lexpr
OP2
lexpr
{
mk_pp
(
PPinfix
(
$
1
,
mk_id
(
infix
$
2
)
(
loc_i
2
)
,
$
3
))
}
{
mk_pp
(
PPinfix
(
$
1
,
mk_id
(
infix
$
2
)
(
f
loc_i
2
)
,
$
3
))
}
|
lexpr
OP3
lexpr
{
mk_pp
(
PPinfix
(
$
1
,
mk_id
(
infix
$
2
)
(
loc_i
2
)
,
$
3
))
}
{
mk_pp
(
PPinfix
(
$
1
,
mk_id
(
infix
$
2
)
(
f
loc_i
2
)
,
$
3
))
}
|
lexpr
OP4
lexpr
{
mk_pp
(
PPinfix
(
$
1
,
mk_id
(
infix
$
2
)
(
loc_i
2
)
,
$
3
))
}
{
mk_pp
(
PPinfix
(
$
1
,
mk_id
(
infix
$
2
)
(
f
loc_i
2
)
,
$
3
))
}
|
any_op
lexpr
%
prec
prefix_op
{
mk_pp
(
PPapp
(
Qident
(
mk_id
(
prefix
$
1
)
(
loc_i
2
))
,
[
$
2
]))
}
{
mk_pp
(
PPapp
(
Qident
(
mk_id
(
prefix
$
1
)
(
f
loc_i
2
))
,
[
$
2
]))
}
|
qualid
list1_lexpr_arg
{
mk_pp
(
PPapp
(
$
1
,
$
2
))
}
|
IF
lexpr
THEN
lexpr
ELSE
lexpr
...
...
@@ -599,7 +592,7 @@ lexpr_arg:
|
FALSE
{
mk_pp
PPfalse
}
|
OPPREF
lexpr_arg
{
mk_pp
(
PPapp
(
Qident
(
mk_id
(
prefix
$
1
)
(
loc_i
2
))
,
[
$
2
]))
}
{
mk_pp
(
PPapp
(
Qident
(
mk_id
(
prefix
$
1
)
(
f
loc_i
2
))
,
[
$
2
]))
}
|
lexpr_sub
{
$
1
}
;
...
...
@@ -608,7 +601,7 @@ lexpr_dot:
|
lqualid_rich
{
mk_pp
(
PPvar
$
1
)
}
|
OPPREF
lexpr_dot
{
mk_pp
(
PPapp
(
Qident
(
mk_id
(
prefix
$
1
)
(
loc_i
2
))
,
[
$
2
]))
}
{
mk_pp
(
PPapp
(
Qident
(
mk_id
(
prefix
$
1
)
(
f
loc_i
2
))
,
[
$
2
]))
}
|
lexpr_sub
{
$
1
}
;
...
...
@@ -627,10 +620,10 @@ lexpr_sub:
|
LEFTREC
lexpr_arg
WITH
list1_field_value
opt_semicolon
RIGHTREC
{
mk_pp
(
PPupdate
(
$
2
,
List
.
rev
$
4
))
}
|
lexpr_arg
LEFTSQ
lexpr
RIGHTSQ
{
mk_pp
(
PPapp
(
Qident
(
mk_id
(
misfix
"[]"
)
(
loc
()
))
,
[
$
1
;
$
3
]))
}
{
mk_pp
(
PPapp
(
Qident
(
mk_id
(
misfix
"[]"
)
(
f
loc
()
))
,
[
$
1
;
$
3
]))
}
|
lexpr_arg
LEFTSQ
lexpr
OP1
lexpr
RIGHTSQ
{
let
op
=
"["
^
$
4
^
"]"
in
mk_pp
(
PPapp
(
Qident
(
mk_id
(
misfix
op
)
(
loc
()
))
,
[
$
1
;
$
3
;
$
5
]))
}
mk_pp
(
PPapp
(
Qident
(
mk_id
(
misfix
op
)
(
f
loc
()
))
,
[
$
1
;
$
3
;
$
5
]))
}
;
quant
:
...
...
@@ -797,22 +790,22 @@ lident_rich:
|
lident
{
$
1
}
|
LEFTPAR
lident_op
RIGHTPAR
{
mk_id
(
infix
$
2
)
(
loc
()
)
}
{
mk_id
(
infix
$
2
)
(
f
loc
()
)
}
|
LEFTPAR_STAR_RIGHTPAR
{
mk_id
(
infix
"*"
)
(
loc
()
)
}
{
mk_id
(
infix
"*"
)
(
f
loc
()
)
}
|
LEFTPAR
lident_op
UNDERSCORE
RIGHTPAR
{
mk_id
(
prefix
$
2
)
(
loc
()
)
}
{
mk_id
(
prefix
$
2
)
(
f
loc
()
)
}
|
LEFTPAR
OPPREF
RIGHTPAR
{
mk_id
(
prefix
$
2
)
(
loc
()
)
}
{
mk_id
(
prefix
$
2
)
(
f
loc
()
)
}
|
LEFTPAR
LEFTSQ
RIGHTSQ
RIGHTPAR
{
mk_id
(
misfix
"[]"
)
(
loc
()
)
}
{
mk_id
(
misfix
"[]"
)
(
f
loc
()
)
}
|
LEFTPAR
LEFTSQ
OP1
RIGHTSQ
RIGHTPAR
{
mk_id
(
misfix
(
"["
^
$
3
^
"]"
))
(
loc
()
)
}
{
mk_id
(
misfix
(
"["
^
$
3
^
"]"
))
(
f
loc
()
)
}
;
lident
:
|
LIDENT
{
mk_id
$
1
(
loc
()
)
}
|
MODEL
{
mk_id
"model"
(
loc
()
)
}
|
LIDENT
{
mk_id
$
1
(
f
loc
()
)
}
|
MODEL
{
mk_id
"model"
(
f
loc
()
)
}
;
lident_op
:
...
...
@@ -831,7 +824,7 @@ any_op:
;
uident
:
|
UIDENT
{
mk_id
$
1
(
loc
()
)
}
|
UIDENT
{
mk_id
$
1
(
f
loc
()
)
}
;
lq_lident
:
...
...
@@ -878,10 +871,10 @@ label:
|
STRING
{
Ident
.
label
$
1
}
|
STRING
BACKQUOTE
INTEGER
BACKQUOTE
INTEGER
BACKQUOTE
INTEGER
BACKQUOTE
INTEGER
BACKQUOTE
STRING
{
let
loc
=
user_loc
$
11
(
int_of_string
$
3
)
(
int_of_string
$
5
)
(
int_of_string
$
7
)
(
int_of_string
$
9
)
in
Ident
.
label
~
loc
$
1
}
BACKQUOTE
INTEGER
BACKQUOTE
STRING
{
let
loc
=
Loc
.
user_position
$
9
(
int_of_string
$
3
)
(
int_of_string
$
5
)
(
int_of_string
$
7
)
in
Ident
.
label
~
loc
$
1
}
;