Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
cduce
cduce
Commits
02a96b54
Commit
02a96b54
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2003-05-10 18:31:04 by cvscast] Special nodes to locate expressions
Original author: cvscast Date: 2003-05-10 18:31:04+00:00
parent
57aef957
Changes
6
Hide whitespace changes
Inline
Side-by-side
driver/cduce.ml
View file @
02a96b54
...
...
@@ -163,7 +163,7 @@ let run ppf ppf_err input =
let
v
=
Eval
.
eval
Eval
.
Env
.
empty
e
in
if
not
!
quiet
then
Format
.
fprintf
ppf
"=> @[%a@]@
\n
@."
print_value
v
|
Ast
.
LetDecl
(
p
,
{
descr
=
Ast
.
Abstraction
_
}
)
->
()
|
Ast
.
LetDecl
(
p
,
Ast
.
Abstraction
_
)
->
()
|
Ast
.
LetDecl
(
p
,
e
)
->
let
decl
=
Typer
.
let_decl
p
e
in
type_decl
decl
;
...
...
@@ -181,7 +181,7 @@ let run ppf ppf_err input =
List
.
iter
eval_decl
decls
in
let
rec
phrases
funs
=
function
|
{
descr
=
Ast
.
LetDecl
(
p
,
(
{
descr
=
Ast
.
Abstraction
_
}
as
e
))}
::
phs
->
|
{
descr
=
Ast
.
LetDecl
(
p
,
(
Ast
.
Abstraction
_
as
e
))
}
::
phs
->
phrases
((
p
,
e
)
::
funs
)
phs
|
ph
::
phs
->
do_fun_decls
funs
;
...
...
@@ -201,7 +201,7 @@ let run ppf ppf_err input =
List
.
fold_left
(
fun
((
typs
,
funs
)
as
accu
)
ph
->
match
ph
.
descr
with
|
Ast
.
TypeDecl
(
x
,
t
)
->
((
x
,
t
)
::
typs
,
funs
)
|
Ast
.
LetDecl
(
p
,
(
{
descr
=
Ast
.
Abstraction
_
}
as
e
))
->
|
Ast
.
LetDecl
(
p
,
(
Ast
.
Abstraction
_
as
e
))
->
(
typs
,
(
p
,
e
)
::
funs
)
|
_
->
accu
)
([]
,
[]
)
p
in
...
...
parser/ast.ml
View file @
02a96b54
...
...
@@ -23,9 +23,11 @@ and debug_directive =
]
and
pexpr
=
pexpr'
located
and
pexpr'
=
and
pexpr
=
|
LocatedExpr
of
loc
*
pexpr
|
Forget
of
pexpr
*
ppat
(* CDuce is a Lambda-calculus ... *)
|
Var
of
id
|
Apply
of
pexpr
*
pexpr
...
...
parser/location.ml
View file @
02a96b54
...
...
@@ -101,6 +101,7 @@ type 'a located = { loc : loc; descr : 'a }
let
mk
(
i
,
j
)
x
=
{
loc
=
(
!
source
,
i
,
j
);
descr
=
x
}
let
mk_loc
loc
x
=
{
loc
=
loc
;
descr
=
x
}
let
mknoloc
x
=
{
loc
=
noloc
;
descr
=
x
}
let
loc_of_pos
(
i
,
j
)
=
(
!
source
,
i
,
j
)
let
protect
ppf
f
=
match
!
viewport
with
...
...
parser/location.mli
View file @
02a96b54
...
...
@@ -33,6 +33,8 @@ val mk: int * int -> 'a -> 'a located
val
mk_loc
:
loc
->
'
a
->
'
a
located
val
mknoloc
:
'
a
->
'
a
located
val
loc_of_pos
:
int
*
int
->
loc
(* Are we working in a protected environement (web prototype ...) ? *)
val
set_protected
:
bool
->
unit
...
...
parser/parser.ml
View file @
02a96b54
...
...
@@ -15,25 +15,26 @@ let pat = Grammar.Entry.create gram "type/pattern expression"
let
regexp
=
Grammar
.
Entry
.
create
gram
"type/pattern regexp"
let
const
=
Grammar
.
Entry
.
create
gram
"scalar constant"
let
exp
pos
e
=
LocatedExpr
(
loc_of_pos
pos
,
e
)
let
rec
multi_prod
loc
=
function
|
[
x
]
->
x
|
x
::
l
->
mk
loc
(
Prod
(
x
,
multi_prod
loc
l
))
|
[]
->
assert
false
let
rec
tuple
loc
=
function
let
rec
tuple
=
function
|
[
x
]
->
x
|
x
::
l
->
mk
loc
(
Pair
(
x
,
tuple
l
oc
l
)
)
|
x
::
l
->
Pair
(
x
,
tuple
l
)
|
[]
->
assert
false
let
tuple_queue
=
List
.
fold_right
(
fun
x
q
->
mk_loc
x
.
loc
(
Pair
(
x
,
q
)))
List
.
fold_right
(
fun
x
q
->
Pair
(
x
,
q
))
let
char
=
mknoloc
(
Internal
(
Types
.
char
Chars
.
any
))
let
string_regexp
=
Star
(
Elem
char
)
let
cst_nil
=
mknoloc
(
Cst
(
Types
.
Atom
Sequence
.
nil_atom
)
)
let
cst_nil
=
Cst
(
Types
.
Atom
Sequence
.
nil_atom
)
let
seq_of_string
pos
s
=
let
s
=
Encodings
.
Utf8
.
mk
s
in
...
...
@@ -61,7 +62,7 @@ let parse_char loc s =
let
char_list
pos
s
=
let
s
=
seq_of_string
pos
s
in
List
.
map
(
fun
(
loc
,
c
)
->
mk
loc
(
Cst
(
Types
.
Char
(
Chars
.
mk_int
c
))))
s
List
.
map
(
fun
(
loc
,
c
)
->
exp
loc
(
Cst
(
Types
.
Char
(
Chars
.
mk_int
c
))))
s
let
include_stack
=
ref
[]
...
...
@@ -76,7 +77,7 @@ EXTEND
phrase
:
[
[
(
p
,
e
)
=
let_binding
->
[
mk
loc
(
LetDecl
(
p
,
e
))
]
|
(
p
,
e1
)
=
let_binding
;
"in"
;
e2
=
expr
LEVEL
"top"
->
[
mk
loc
(
EvalStatement
(
mk
loc
(
Match
(
e1
,
[
p
,
e2
]))))
]
[
mk
loc
(
EvalStatement
(
exp
loc
(
Match
(
e1
,
[
p
,
e2
]))))
]
|
LIDENT
"type"
;
x
=
UIDENT
;
"="
;
t
=
pat
->
[
mk
loc
(
TypeDecl
(
x
,
t
))
]
|
LIDENT
"debug"
;
d
=
debug_directive
->
[
mk
loc
(
Debug
d
)
]
|
LIDENT
"include"
;
s
=
STRING2
->
...
...
@@ -111,27 +112,27 @@ EXTEND
expr
:
[
"top"
RIGHTA
[
"match"
;
e
=
SELF
;
"with"
;
b
=
branches
->
mk
loc
(
Match
(
e
,
b
))
[
"match"
;
e
=
SELF
;
"with"
;
b
=
branches
->
exp
loc
(
Match
(
e
,
b
))
|
"try"
;
e
=
SELF
;
"with"
;
b
=
branches
->
let
default
=
(
mknoloc
(
Capture
(
ident
"x"
))
,
mknoloc
(
Op
(
"raise"
,
[
mknoloc
(
Var
(
ident
"x"
)
)]))
)
in
mk
loc
(
Try
(
e
,
b
@
[
default
]))
|
"map"
;
e
=
SELF
;
"with"
;
b
=
branches
->
mk
loc
(
Map
(
e
,
b
))
|
"ttree"
;
e
=
SELF
;
"with"
;
b
=
branches
->
mk
loc
(
Ttree
(
e
,
b
))
mknoloc
(
Capture
(
ident
"x"
))
,
Op
(
"raise"
,
[
Var
(
ident
"x"
)
]
)
in
exp
loc
(
Try
(
e
,
b
@
[
default
]))
|
"map"
;
e
=
SELF
;
"with"
;
b
=
branches
->
exp
loc
(
Map
(
e
,
b
))
|
"ttree"
;
e
=
SELF
;
"with"
;
b
=
branches
->
exp
loc
(
Ttree
(
e
,
b
))
|
"if"
;
e
=
SELF
;
"then"
;
e1
=
SELF
;
"else"
;
e2
=
SELF
->
let
p1
=
mk
loc
(
Internal
(
Builtin
.
true_type
))
and
p2
=
mk
loc
(
Internal
(
Builtin
.
false_type
))
in
mk
loc
(
Match
(
e
,
[
p1
,
e1
;
p2
,
e2
]))
exp
loc
(
Match
(
e
,
[
p1
,
e1
;
p2
,
e2
]))
|
"transform"
;
e
=
SELF
;
"with"
;
b
=
branches
->
let
default
=
mknoloc
(
Capture
(
ident
"x"
))
,
cst_nil
in
mk
loc
(
Op
(
"flatten"
,
[
mk
loc
(
Map
(
e
,
b
@
[
default
])
)
]))
exp
loc
(
Op
(
"flatten"
,
[
Map
(
e
,
b
@
[
default
])]))
|
"fun"
;
(
f
,
a
,
b
)
=
fun_decl
->
mk
loc
(
Abstraction
{
fun_name
=
f
;
fun_iface
=
a
;
fun_body
=
b
})
exp
loc
(
Abstraction
{
fun_name
=
f
;
fun_iface
=
a
;
fun_body
=
b
})
|
(
p
,
e1
)
=
let_binding
;
"in"
;
e2
=
expr
LEVEL
"top"
->
mk
loc
(
Match
(
e1
,
[
p
,
e2
]))
exp
loc
(
Match
(
e1
,
[
p
,
e2
]))
|
e
=
expr
;
":"
;
p
=
pat
->
mk
loc
(
Forget
(
e
,
p
))
exp
loc
(
Forget
(
e
,
p
))
]
...
...
@@ -141,17 +142,17 @@ EXTEND
|
"<<"
->
"<"
|
">>"
->
">"
|
s
->
s
in
mk
loc
(
Op
(
op
,
[
e1
;
e2
]))
exp
loc
(
Op
(
op
,
[
e1
;
e2
]))
]
|
[
e1
=
expr
;
op
=
[
"+"
|
"-"
|
"@"
];
e2
=
expr
->
mk
loc
(
Op
(
op
,
[
e1
;
e2
]))
exp
loc
(
Op
(
op
,
[
e1
;
e2
]))
|
e
=
expr
;
"
\\
"
;
l
=
[
LIDENT
|
UIDENT
]
->
mk
loc
(
RemoveField
(
e
,
LabelPool
.
mk
l
))
exp
loc
(
RemoveField
(
e
,
LabelPool
.
mk
l
))
]
|
[
e1
=
expr
;
op
=
[
"*"
];
e2
=
expr
->
mk
loc
(
Op
(
op
,
[
e1
;
e2
]))
[
e1
=
expr
;
op
=
[
"*"
];
e2
=
expr
->
exp
loc
(
Op
(
op
,
[
e1
;
e2
]))
|
e
=
expr
;
op
=
"/"
;
p
=
pat
->
let
tag
=
mk
loc
(
Internal
(
Types
.
atom
(
Atoms
.
any
)))
in
...
...
@@ -160,12 +161,12 @@ EXTEND
let
re
=
Star
(
Alt
(
SeqCapture
(
ident
"x"
,
Elem
p
)
,
Elem
any
))
in
let
ct
=
mk
loc
(
Regexp
(
re
,
any
))
in
let
p
=
mk
loc
(
XmlT
(
tag
,
multi_prod
loc
[
att
;
ct
]))
in
let
b
=
(
p
,
mk
loc
(
Var
(
ident
"x"
))
)
in
mk
loc
(
Op
(
"flatten"
,
[
mk
loc
(
Map
(
e
,
[
b
])
)
]))
let
b
=
(
p
,
Var
(
ident
"x"
))
in
exp
loc
(
Op
(
"flatten"
,
[
Map
(
e
,
[
b
])]))
]
|
[
e
=
expr
;
"."
;
l
=
[
LIDENT
|
UIDENT
]
->
mk
loc
(
Dot
(
e
,
LabelPool
.
mk
l
))
exp
loc
(
Dot
(
e
,
LabelPool
.
mk
l
))
]
|
...
...
@@ -179,34 +180,34 @@ EXTEND
|
LIDENT
"int_of"
|
LIDENT
"string_of"
];
e
=
expr
->
mk
loc
(
Op
(
op
,
[
e
]))
e
=
expr
->
exp
loc
(
Op
(
op
,
[
e
]))
|
op
=
[
LIDENT
"dump_to_file"
];
e1
=
expr
LEVEL
"no_appl"
;
e2
=
expr
->
mk
loc
(
Op
(
op
,
[
e1
;
e2
]))
|
e1
=
SELF
;
LIDENT
"div"
;
e2
=
expr
->
mk
loc
(
Op
(
"/"
,
[
e1
;
e2
]))
|
e1
=
SELF
;
LIDENT
"mod"
;
e2
=
expr
->
mk
loc
(
Op
(
"mod"
,
[
e1
;
e2
]))
|
e1
=
SELF
;
e2
=
expr
->
mk
loc
(
Apply
(
e1
,
e2
))
e1
=
expr
LEVEL
"no_appl"
;
e2
=
expr
->
exp
loc
(
Op
(
op
,
[
e1
;
e2
]))
|
e1
=
SELF
;
LIDENT
"div"
;
e2
=
expr
->
exp
loc
(
Op
(
"/"
,
[
e1
;
e2
]))
|
e1
=
SELF
;
LIDENT
"mod"
;
e2
=
expr
->
exp
loc
(
Op
(
"mod"
,
[
e1
;
e2
]))
|
e1
=
SELF
;
e2
=
expr
->
exp
loc
(
Apply
(
e1
,
e2
))
]
|
"no_appl"
[
c
=
const
->
mk
loc
(
Cst
c
)
|
"("
;
l
=
LIST1
expr
SEP
","
;
")"
->
tuple
loc
l
[
c
=
const
->
exp
loc
(
Cst
c
)
|
"("
;
l
=
LIST1
expr
SEP
","
;
")"
->
exp
loc
(
tuple
l
)
|
"["
;
l
=
LIST0
seq_elem
;
e
=
OPT
[
";"
;
e
=
expr
->
e
];
"]"
->
let
e
=
match
e
with
Some
e
->
e
|
None
->
cst_nil
in
List
.
fold_right
(
fun
x
q
->
match
x
with
|
`Elems
l
->
tuple_queue
l
q
|
`Explode
x
->
mk_loc
x
.
loc
(
Op
(
"@"
,
[
x
;
q
])
)
|
`Explode
x
->
Op
(
"@"
,
[
x
;
q
])
)
l
e
|
t
=
[
a
=
TAG
->
mk
loc
(
Cst
(
Types
.
Atom
(
Atoms
.
mk
a
)))
exp
loc
(
Cst
(
Types
.
Atom
(
Atoms
.
mk
a
)))
|
"<"
;
e
=
expr
LEVEL
"no_appl"
->
e
];
a
=
expr_attrib_spec
;
">"
;
c
=
expr
->
mk
loc
(
Xml
(
t
,
mk
loc
(
Pair
(
a
,
c
)))
)
|
"{"
;
r
=
[
expr_record_spec
|
->
mk
loc
(
RecordLitt
LabelMap
.
empty
)
];
"}"
->
r
exp
loc
(
Xml
(
t
,
Pair
(
a
,
c
)))
|
"{"
;
r
=
[
expr_record_spec
|
->
exp
loc
(
RecordLitt
LabelMap
.
empty
)
];
"}"
->
r
|
s
=
STRING2
->
tuple
loc
(
char_list
loc
s
@
[
cst_nil
])
|
a
=
LIDENT
->
mk
loc
(
Var
(
ident
a
))
exp
loc
(
tuple
(
char_list
loc
s
@
[
cst_nil
])
)
|
a
=
LIDENT
->
exp
loc
(
Var
(
ident
a
))
]
];
...
...
@@ -220,14 +221,14 @@ EXTEND
let_binding
:
[
[
"let"
;
p
=
pat
;
"="
;
e
=
expr
->
(
p
,
e
)
|
"let"
;
p
=
pat
;
":"
;
t
=
pat
;
"="
;
e
=
expr
->
(
p
,
mknoloc
(
Forget
(
e
,
t
))
)
|
"let"
;
p
=
pat
;
":"
;
t
=
pat
;
"="
;
e
=
expr
->
(
p
,
Forget
(
e
,
t
))
|
"let"
;
"fun"
;
(
f
,
a
,
b
)
=
fun_decl
->
let
p
=
match
f
with
|
Some
x
->
mk
loc
(
Capture
x
)
|
_
->
failwith
"Function name mandatory in let fun declarations"
in
let
abst
=
{
fun_name
=
f
;
fun_iface
=
a
;
fun_body
=
b
}
in
let
e
=
mk
loc
(
Abstraction
abst
)
in
let
e
=
exp
loc
(
Abstraction
abst
)
in
(
p
,
e
);
]
];
...
...
@@ -403,13 +404,13 @@ EXTEND
[
l
=
[
LIDENT
|
UIDENT
];
"="
;
x
=
expr
->
(
LabelPool
.
mk
l
,
x
)
]
SEP
";"
->
mk
loc
(
RecordLitt
(
make_record
loc
r
))
exp
loc
(
RecordLitt
(
make_record
loc
r
))
]
];
expr_attrib_spec
:
[
[
r
=
expr_record_spec
->
r
]
|
[
e
=
expr
LEVEL
"no_appl"
->
e
|
->
mk
loc
(
RecordLitt
(
LabelMap
.
empty
))
|
->
exp
loc
(
RecordLitt
(
LabelMap
.
empty
))
]
];
END
...
...
typing/typer.ml
View file @
02a96b54
...
...
@@ -484,95 +484,98 @@ let all_branches = ref []
(* IDEA: introduce a node Loc in the AST to override nolocs
in sub-expressions *)
let
rec
expr
loc'
{
loc
=
loc
;
descr
=
d
}
=
let
loc
=
if
loc
=
noloc
then
loc'
else
loc
in
let
(
fv
,
td
)
=
match
d
with
|
Forget
(
e
,
t
)
->
let
(
fv
,
e
)
=
expr
loc
e
and
t
=
typ
t
in
(
fv
,
Typed
.
Forget
(
e
,
t
))
|
Var
s
->
(
Fv
.
singleton
s
,
Typed
.
Var
s
)
|
Apply
(
e1
,
e2
)
->
let
(
fv1
,
e1
)
=
expr
loc
e1
and
(
fv2
,
e2
)
=
expr
loc
e2
in
(
Fv
.
cup
fv1
fv2
,
Typed
.
Apply
(
e1
,
e2
))
|
Abstraction
a
->
let
iface
=
List
.
map
(
fun
(
t1
,
t2
)
->
(
typ
t1
,
typ
t2
))
a
.
fun_iface
in
let
t
=
List
.
fold_left
(
fun
accu
(
t1
,
t2
)
->
Types
.
cap
accu
(
Types
.
arrow
t1
t2
))
Types
.
any
iface
in
let
iface
=
List
.
map
(
fun
(
t1
,
t2
)
->
(
Types
.
descr
t1
,
Types
.
descr
t2
))
iface
in
let
(
fv0
,
body
)
=
branches
loc
a
.
fun_body
in
let
fv
=
match
a
.
fun_name
with
|
None
->
fv0
|
Some
f
->
Fv
.
remove
f
fv0
in
(
fv
,
Typed
.
Abstraction
{
Typed
.
fun_name
=
a
.
fun_name
;
Typed
.
fun_iface
=
iface
;
Typed
.
fun_body
=
body
;
Typed
.
fun_typ
=
t
;
Typed
.
fun_fv
=
fv
}
)
|
Cst
c
->
(
Fv
.
empty
,
Typed
.
Cst
c
)
|
Pair
(
e1
,
e2
)
->
let
(
fv1
,
e1
)
=
expr
loc
e1
and
(
fv2
,
e2
)
=
expr
loc
e2
in
(
Fv
.
cup
fv1
fv2
,
Typed
.
Pair
(
e1
,
e2
))
|
Xml
(
e1
,
e2
)
->
let
(
fv1
,
e1
)
=
expr
loc
e1
and
(
fv2
,
e2
)
=
expr
loc
e2
in
(
Fv
.
cup
fv1
fv2
,
Typed
.
Xml
(
e1
,
e2
))
|
Dot
(
e
,
l
)
->
let
(
fv
,
e
)
=
expr
loc
e
in
(
fv
,
Typed
.
Dot
(
e
,
l
))
|
RemoveField
(
e
,
l
)
->
let
(
fv
,
e
)
=
expr
loc
e
in
(
fv
,
Typed
.
RemoveField
(
e
,
l
))
|
RecordLitt
r
->
let
fv
=
ref
Fv
.
empty
in
let
r
=
LabelMap
.
map
(
fun
e
->
let
(
fv2
,
e
)
=
expr
loc
e
in
fv
:=
Fv
.
cup
!
fv
fv2
;
e
)
r
in
(
!
fv
,
Typed
.
RecordLitt
r
)
|
Op
(
op
,
le
)
->
let
(
fvs
,
ltes
)
=
List
.
split
(
List
.
map
(
expr
loc
)
le
)
in
let
fv
=
List
.
fold_left
Fv
.
cup
Fv
.
empty
fvs
in
(
fv
,
Typed
.
Op
(
op
,
ltes
))
|
Match
(
e
,
b
)
->
let
(
fv1
,
e
)
=
expr
loc
e
and
(
fv2
,
b
)
=
branches
loc
b
in
(
Fv
.
cup
fv1
fv2
,
Typed
.
Match
(
e
,
b
))
|
Map
(
e
,
b
)
->
let
(
fv1
,
e
)
=
expr
loc
e
and
(
fv2
,
b
)
=
branches
loc
b
in
(
Fv
.
cup
fv1
fv2
,
Typed
.
Map
(
e
,
b
))
|
Ttree
(
e
,
b
)
->
let
b
=
b
@
[
(
mknoloc
(
Internal
Types
.
any
))
,
mknoloc
MatchFail
]
in
let
(
fv1
,
e
)
=
expr
loc
e
and
(
fv2
,
b
)
=
branches
loc
b
in
(
Fv
.
cup
fv1
fv2
,
Typed
.
Ttree
(
e
,
b
))
|
MatchFail
->
(
Fv
.
empty
,
Typed
.
MatchFail
)
|
Try
(
e
,
b
)
->
let
(
fv1
,
e
)
=
expr
loc
e
and
(
fv2
,
b
)
=
branches
loc
b
in
(
Fv
.
cup
fv1
fv2
,
Typed
.
Try
(
e
,
b
))
in
let
exp
loc
fv
e
=
fv
,
{
Typed
.
exp_loc
=
loc
;
Typed
.
exp_typ
=
Types
.
empty
;
Typed
.
exp_descr
=
td
;
Typed
.
exp_descr
=
e
;
}
let
rec
expr
loc
=
function
|
LocatedExpr
(
loc
,
e
)
->
expr
loc
e
|
Forget
(
e
,
t
)
->
let
(
fv
,
e
)
=
expr
loc
e
and
t
=
typ
t
in
exp
loc
fv
(
Typed
.
Forget
(
e
,
t
))
|
Var
s
->
exp
loc
(
Fv
.
singleton
s
)
(
Typed
.
Var
s
)
|
Apply
(
e1
,
e2
)
->
let
(
fv1
,
e1
)
=
expr
loc
e1
and
(
fv2
,
e2
)
=
expr
loc
e2
in
exp
loc
(
Fv
.
cup
fv1
fv2
)
(
Typed
.
Apply
(
e1
,
e2
))
|
Abstraction
a
->
let
iface
=
List
.
map
(
fun
(
t1
,
t2
)
->
(
typ
t1
,
typ
t2
))
a
.
fun_iface
in
let
t
=
List
.
fold_left
(
fun
accu
(
t1
,
t2
)
->
Types
.
cap
accu
(
Types
.
arrow
t1
t2
))
Types
.
any
iface
in
let
iface
=
List
.
map
(
fun
(
t1
,
t2
)
->
(
Types
.
descr
t1
,
Types
.
descr
t2
))
iface
in
let
(
fv0
,
body
)
=
branches
a
.
fun_body
in
let
fv
=
match
a
.
fun_name
with
|
None
->
fv0
|
Some
f
->
Fv
.
remove
f
fv0
in
let
e
=
Typed
.
Abstraction
{
Typed
.
fun_name
=
a
.
fun_name
;
Typed
.
fun_iface
=
iface
;
Typed
.
fun_body
=
body
;
Typed
.
fun_typ
=
t
;
Typed
.
fun_fv
=
fv
}
in
exp
loc
fv
e
|
Cst
c
->
exp
loc
Fv
.
empty
(
Typed
.
Cst
c
)
|
Pair
(
e1
,
e2
)
->
let
(
fv1
,
e1
)
=
expr
loc
e1
and
(
fv2
,
e2
)
=
expr
loc
e2
in
exp
loc
(
Fv
.
cup
fv1
fv2
)
(
Typed
.
Pair
(
e1
,
e2
))
|
Xml
(
e1
,
e2
)
->
let
(
fv1
,
e1
)
=
expr
loc
e1
and
(
fv2
,
e2
)
=
expr
loc
e2
in
exp
loc
(
Fv
.
cup
fv1
fv2
)
(
Typed
.
Xml
(
e1
,
e2
))
|
Dot
(
e
,
l
)
->
let
(
fv
,
e
)
=
expr
loc
e
in
exp
loc
fv
(
Typed
.
Dot
(
e
,
l
))
|
RemoveField
(
e
,
l
)
->
let
(
fv
,
e
)
=
expr
loc
e
in
exp
loc
fv
(
Typed
.
RemoveField
(
e
,
l
))
|
RecordLitt
r
->
let
fv
=
ref
Fv
.
empty
in
let
r
=
LabelMap
.
map
(
fun
e
->
let
(
fv2
,
e
)
=
expr
loc
e
in
fv
:=
Fv
.
cup
!
fv
fv2
;
e
)
r
in
exp
loc
!
fv
(
Typed
.
RecordLitt
r
)
|
Op
(
op
,
le
)
->
let
(
fvs
,
ltes
)
=
List
.
split
(
List
.
map
(
expr
loc
)
le
)
in
let
fv
=
List
.
fold_left
Fv
.
cup
Fv
.
empty
fvs
in
exp
loc
fv
(
Typed
.
Op
(
op
,
ltes
))
|
Match
(
e
,
b
)
->
let
(
fv1
,
e
)
=
expr
loc
e
and
(
fv2
,
b
)
=
branches
b
in
exp
loc
(
Fv
.
cup
fv1
fv2
)
(
Typed
.
Match
(
e
,
b
))
|
Map
(
e
,
b
)
->
let
(
fv1
,
e
)
=
expr
loc
e
and
(
fv2
,
b
)
=
branches
b
in
exp
loc
(
Fv
.
cup
fv1
fv2
)
(
Typed
.
Map
(
e
,
b
))
|
Ttree
(
e
,
b
)
->
let
b
=
b
@
[
mknoloc
(
Internal
Types
.
any
)
,
MatchFail
]
in
let
(
fv1
,
e
)
=
expr
loc
e
and
(
fv2
,
b
)
=
branches
b
in
exp
loc
(
Fv
.
cup
fv1
fv2
)
(
Typed
.
Ttree
(
e
,
b
))
|
MatchFail
->
exp
loc
(
Fv
.
empty
)
Typed
.
MatchFail
|
Try
(
e
,
b
)
->
let
(
fv1
,
e
)
=
expr
loc
e
and
(
fv2
,
b
)
=
branches
b
in
exp
loc
(
Fv
.
cup
fv1
fv2
)
(
Typed
.
Try
(
e
,
b
))
and
branches
loc
b
=
and
branches
b
=
let
fv
=
ref
Fv
.
empty
in
let
accept
=
ref
Types
.
empty
in
let
branch
(
p
,
e
)
=
let
br_loc
=
merge_loc
p
.
loc
e
.
loc
in
let
(
fv2
,
e
)
=
expr
loc
e
in
let
(
fv2
,
e
)
=
expr
no
loc
e
in
let
br_loc
=
merge_loc
p
.
loc
e
.
Typed
.
exp_loc
in
let
p
=
pat
p
in
let
fv2
=
Fv
.
diff
fv2
(
Patterns
.
fv
p
)
in
fv
:=
Fv
.
cup
!
fv
fv2
;
...
...
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