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
42d62b7e
Commit
42d62b7e
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2002-10-30 03:08:01 by cvscast] Empty log message
Original author: cvscast Date: 2002-10-30 03:08:09+00:00
parent
c77c6afd
Changes
7
Hide whitespace changes
Inline
Side-by-side
driver/cduce.ml
View file @
42d62b7e
...
...
@@ -39,6 +39,9 @@ let rec print_exn ppf = function
l1
c1
l2
c2
);
print_exn
ppf
exn
|
Value
.
CDuceExn
v
->
Format
.
fprintf
ppf
"Uncaught CDuce exception: @[%a@]@
\n
"
Value
.
print
v
|
Typer
.
WrongLabel
(
t
,
l
)
->
Format
.
fprintf
ppf
"Wrong record selection: the label %s@
\n
"
(
Types
.
label_name
l
);
...
...
parser/ast.ml
View file @
42d62b7e
...
...
@@ -39,6 +39,10 @@ and pexpr' =
|
Match
of
pexpr
*
branches
|
Map
of
pexpr
*
branches
|
Dot
of
(
pexpr
*
Types
.
label
)
(* Exceptions *)
|
Try
of
pexpr
*
branches
and
abstr
=
{
fun_name
:
string
option
;
fun_iface
:
(
ppat
*
ppat
)
list
;
...
...
parser/parser.ml
View file @
42d62b7e
...
...
@@ -58,6 +58,11 @@ EXTEND
expr
:
[
"top"
RIGHTA
[
"match"
;
e
=
SELF
;
"with"
;
b
=
branches
->
mk
loc
(
Match
(
e
,
b
))
|
"try"
;
e
=
SELF
;
"with"
;
b
=
branches
->
let
default
=
(
mk
noloc
(
Capture
"x"
)
,
mk
noloc
(
Op
(
"raise"
,
[
mk
noloc
(
Var
"x"
)])))
in
mk
loc
(
Try
(
e
,
b
@
[
default
]))
|
"map"
;
e
=
SELF
;
"with"
;
b
=
branches
->
mk
loc
(
Map
(
e
,
b
))
|
"transform"
;
e
=
SELF
;
"with"
;
b
=
branches
->
mk
noloc
(
Op
(
"flatten"
,
[
mk
loc
(
Map
(
e
,
b
))]))
...
...
@@ -83,6 +88,7 @@ EXTEND
|
[
LIDENT
"flatten"
;
e
=
expr
->
mk
loc
(
Op
(
"flatten"
,
[
e
]))
|
LIDENT
"load_xml"
;
e
=
expr
->
mk
loc
(
Op
(
"load_xml"
,
[
e
]))
|
LIDENT
"raise"
;
e
=
expr
->
mk
loc
(
Op
(
"raise"
,
[
e
]))
|
e1
=
expr
;
e2
=
expr
->
mk
loc
(
Apply
(
e1
,
e2
))
]
...
...
runtime/value.ml
View file @
42d62b7e
module
Env
=
Map
.
Make
(
struct
type
t
=
string
let
compare
=
compare
end
)
let
empty_env
=
Env
.
empty
type
t
=
|
Pair
of
t
*
t
|
Record
of
(
Types
.
label
,
t
)
SortedMap
.
t
...
...
@@ -16,6 +17,8 @@ and abstr = {
fun_body
:
Typed
.
branches
;
}
exception
CDuceExn
of
t
let
rec
is_seq
=
function
|
Pair
(
_
,
y
)
when
is_seq
y
->
true
|
Atom
a
when
a
=
Sequence
.
nil_atom
->
true
...
...
@@ -318,6 +321,9 @@ let rec eval env e0 =
|
Typed
.
Cst
c
->
const
c
|
Typed
.
Match
(
arg
,
brs
)
->
eval_branches
env
brs
(
eval
env
arg
)
|
Typed
.
Map
(
arg
,
brs
)
->
eval_map
env
brs
(
eval
env
arg
)
|
Typed
.
Op
(
"raise"
,
[
e
])
->
raise
(
CDuceExn
(
eval
env
e
))
|
Typed
.
Try
(
arg
,
brs
)
->
(
try
eval
env
arg
with
CDuceExn
v
->
eval_branches
env
brs
v
)
|
Typed
.
Op
(
"flatten"
,
[
e
])
->
eval_flatten
(
eval
env
e
)
|
Typed
.
Op
(
"@"
,
[
e1
;
e2
])
->
eval_concat
(
eval
env
e1
)
(
eval
env
e2
)
|
Typed
.
Op
(
"+"
,
[
e1
;
e2
])
->
eval_add
(
eval
env
e1
)
(
eval
env
e2
)
...
...
@@ -327,7 +333,7 @@ let rec eval env e0 =
|
Typed
.
Op
(
"load_xml"
,
[
e
])
->
eval_load_xml
(
eval
env
e
)
|
Typed
.
Dot
(
e
,
l
)
->
eval_dot
l
(
eval
env
e
)
|
Typed
.
DebugTyper
t
->
failwith
"Evaluating a ! expression"
|
_
->
failwith
"Unknown
expression"
|
Typed
.
Op
(
o
,_
)
->
failwith
(
"Unknown
operator "
^
o
)
and
eval_apply
f
arg
=
match
f
with
...
...
runtime/value.mli
View file @
42d62b7e
...
...
@@ -2,6 +2,8 @@ type t
and
abstr
and
env
exception
CDuceExn
of
t
val
empty_env
:
env
val
print
:
Format
.
formatter
->
t
->
unit
...
...
typing/typed.ml
View file @
42d62b7e
...
...
@@ -37,6 +37,9 @@ and texpr' =
|
Match
of
texpr
*
branches
|
Map
of
texpr
*
branches
|
Dot
of
(
texpr
*
Types
.
label
)
(* Exception *)
|
Try
of
texpr
*
branches
and
abstr
=
{
fun_name
:
string
option
;
...
...
typing/typer.ml
View file @
42d62b7e
...
...
@@ -363,6 +363,10 @@ let rec expr { loc = loc; descr = d } =
let
(
fv1
,
e
)
=
expr
e
and
(
fv2
,
b
)
=
branches
b
in
(
Fv
.
union
fv1
fv2
,
Typed
.
Map
(
e
,
b
))
|
Try
(
e
,
b
)
->
let
(
fv1
,
e
)
=
expr
e
and
(
fv2
,
b
)
=
branches
b
in
(
Fv
.
union
fv1
fv2
,
Typed
.
Try
(
e
,
b
))
in
fv
,
{
Typed
.
exp_loc
=
loc
;
...
...
@@ -426,12 +430,18 @@ and type_check' loc env e constr precise = match e with
|
Some
f
->
Env
.
add
f
a
.
fun_typ
env
in
List
.
iter
(
fun
(
t1
,
t2
)
->
ignore
(
type_check_branches
loc
env
t1
a
.
fun_body
t2
false
)
ignore
(
type_check_branches
loc
env
true
t1
a
.
fun_body
t2
false
)
)
a
.
fun_iface
;
t
|
Match
(
e
,
b
)
->
let
t
=
type_check
env
e
b
.
br_accept
true
in
type_check_branches
loc
env
t
b
constr
precise
type_check_branches
loc
env
true
t
b
constr
precise
|
Try
(
e
,
b
)
->
let
te
=
type_check
env
e
constr
precise
in
let
tb
=
type_check_branches
loc
env
false
Types
.
any
b
constr
precise
in
Types
.
cup
te
tb
|
Pair
(
e1
,
e2
)
->
let
rects
=
Types
.
Product
.
get
constr
in
...
...
@@ -493,7 +503,7 @@ and type_check' loc env e constr precise = match e with
let
res
=
Sequence
.
map
(
fun
t
->
type_check_branches
loc
env
t
b
constr'
(
precise
||
(
not
exact
)))
type_check_branches
loc
env
true
t
b
constr'
(
precise
||
(
not
exact
)))
t
in
if
not
exact
then
check
loc
res
constr
""
;
if
precise
then
res
else
constr
...
...
@@ -560,7 +570,7 @@ and compute_type' loc env = function
type_op
loc
op
args
|
Map
(
e
,
b
)
->
let
t
=
compute_type
env
e
in
Sequence
.
map
(
fun
t
->
type_check_branches
loc
env
t
b
Types
.
any
true
)
t
Sequence
.
map
(
fun
t
->
type_check_branches
loc
env
true
t
b
Types
.
any
true
)
t
(* We keep these cases here to allow comparison and benchmarking ...
Just comment the corresponding cases in type_check' to
...
...
@@ -581,24 +591,24 @@ and compute_type' loc env = function
|
_
->
assert
false
and
type_check_branches
loc
env
targ
brs
constr
precise
=
and
type_check_branches
loc
env
exh
targ
brs
constr
precise
=
if
Types
.
is_empty
targ
then
Types
.
empty
else
(
brs
.
br_typ
<-
Types
.
cup
brs
.
br_typ
targ
;
branches_aux
loc
env
targ
branches_aux
loc
env
exh
targ
(
if
precise
then
Types
.
empty
else
constr
)
constr
precise
brs
.
br_branches
)
and
branches_aux
loc
env
targ
tres
constr
precise
=
function
|
[]
->
raise_loc
loc
(
NonExhaustive
targ
)
and
branches_aux
loc
env
exh
targ
tres
constr
precise
=
function
|
[]
->
if
exh
then
raise_loc
loc
(
NonExhaustive
targ
)
else
tres
|
b
::
rem
->
let
p
=
b
.
br_pat
in
let
acc
=
Types
.
descr
(
Patterns
.
accept
p
)
in
let
targ'
=
Types
.
cap
targ
acc
in
if
Types
.
is_empty
targ'
then
branches_aux
loc
env
targ
tres
constr
precise
rem
then
branches_aux
loc
env
exh
targ
tres
constr
precise
rem
else
(
b
.
br_used
<-
true
;
let
res
=
Patterns
.
filter
targ'
p
in
...
...
@@ -609,7 +619,7 @@ and branches_aux loc env targ tres constr precise = function
let
tres
=
if
precise
then
Types
.
cup
t
tres
else
tres
in
let
targ''
=
Types
.
diff
targ
acc
in
if
(
Types
.
non_empty
targ''
)
then
branches_aux
loc
env
targ''
tres
constr
precise
rem
branches_aux
loc
env
exh
targ''
tres
constr
precise
rem
else
tres
)
...
...
@@ -634,6 +644,8 @@ and type_op loc op args =
check
loc1
t1
Sequence
.
string
"The argument of load_xml must be a string (filename)"
;
Types
.
any
|
"raise"
,
[
loc1
,
t1
]
->
Types
.
empty
|
_
->
assert
false
and
type_int_binop
f
loc1
t1
loc2
t2
=
...
...
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