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
ad651c2e
Commit
ad651c2e
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2003-05-25 12:00:22 by cvscast] Menage
Original author: cvscast Date: 2003-05-25 12:00:22+00:00
parent
5869d4b6
Changes
2
Hide whitespace changes
Inline
Side-by-side
parser/parser.ml
View file @
ad651c2e
...
...
@@ -152,10 +152,7 @@ EXTEND
[
"match"
;
e
=
SELF
;
"with"
;
b
=
branches
->
exp
loc
(
Match
(
e
,
b
))
|
"try"
;
e
=
SELF
;
"with"
;
b
=
branches
->
let
default
=
mknoloc
(
Capture
id_dummy
)
,
Op
(
"raise"
,
[
Var
id_dummy
])
in
exp
loc
(
Try
(
e
,
b
@
[
default
]))
exp
loc
(
Try
(
e
,
b
))
|
"map"
;
e
=
SELF
;
"with"
;
b
=
branches
->
exp
loc
(
Map
(
e
,
b
))
|
"xtransform"
;
e
=
SELF
;
"with"
;
b
=
branches
->
...
...
runtime/eval.ml
View file @
ad651c2e
...
...
@@ -15,48 +15,48 @@ let enter_global x v =
(* Evaluation of expressions *)
let
rec
eval
env
e0
=
match
e0
.
Typed
.
exp_descr
with
|
Typed
.
Forget
(
e
,_
)
->
ev
al
env
e
|
Typed
.
Var
s
->
(
try
Env
.
find
s
env
with
Not_found
->
Env
.
find
s
!
glob
al
_
env
)
|
Typed
.
Apply
(
f
,
arg
)
->
eval_apply
(
eval
env
f
)
(
eval
env
arg
)
|
Typed
.
Abstraction
a
->
let
env
=
IdSet
.
fold
(
fun
accu
x
->
try
Env
.
add
x
(
Env
.
find
x
env
)
a
ccu
with
Not_found
->
accu
(* global *)
)
Env
.
empty
a
.
Typed
.
fun_fv
in
let
env_ref
=
ref
env
in
let
rec
self
=
Abstraction
(
a
.
Typed
.
fun_iface
,
eval_branches'
env_ref
a
.
Typed
.
fun_body
)
in
(
match
a
.
Typed
.
f
un_
name
with
|
None
->
(
)
|
Some
f
->
env_ref
:=
Env
.
add
f
self
env
;
);
self
(* Optimizations:
- for the non-recursive case, use eval_branches
- for the recursive case, could cheat by patching self afterwards:
(Obj.magic self).(1) <- ....
*)
|
Typed
.
RecordLitt
r
->
Record
(
LabelMap
.
map
(
eval
env
)
r
)
|
Typed
.
Pair
(
e1
,
e2
)
->
Pair
(
eval
env
e1
,
eval
env
e2
)
|
Typed
.
Xml
(
e1
,
{
Typed
.
exp_descr
=
Typed
.
Pair
(
e2
,
e3
)
})
->
Xml
(
eval
env
e1
,
eval
env
e2
,
eval
env
e3
)
|
Typed
.
Xml
(
_
,_
)
->
assert
false
|
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
.
Xtrans
(
arg
,
brs
)
->
eval_xtrans
env
brs
(
eval
env
arg
)
|
Typed
.
Try
(
arg
,
brs
)
->
(
try
eval
env
arg
with
CDuceExn
v
->
eval_branches
env
brs
v
)
|
Typed
.
Transform
(
arg
,
brs
)
->
eval_transform
env
brs
(
eval
env
arg
)
|
Typed
.
Dot
(
e
,
l
)
->
eval_dot
l
(
eval
env
e
)
|
Typed
.
RemoveField
(
e
,
l
)
->
eval_remove_field
l
(
eval
env
e
)
|
Typed
.
UnaryOp
(
o
,
e
)
->
o
.
Typed
.
un_op_eval
(
eval
env
e
)
|
Typed
.
BinaryOp
(
o
,
e1
,
e2
)
->
o
.
Typed
.
bin_op_eval
(
eval
env
e1
)
(
eval
env
e2
)
let
rec
eval
env
e0
=
match
e0
.
Typed
.
exp_descr
with
|
Typed
.
Forget
(
e
,_
)
->
eval
env
e
|
Typed
.
Var
s
->
(
try
Env
.
find
s
env
with
Not_found
->
Env
.
find
s
!
glob
al
_
env
)
|
Typed
.
Apply
(
f
,
arg
)
->
eval_apply
(
eval
env
f
)
(
eval
env
arg
)
|
Typed
.
Abstraction
a
->
eval_abstraction
env
a
|
Typed
.
RecordLitt
r
->
Record
(
LabelMap
.
map
(
ev
al
env
)
r
)
|
Typed
.
Pair
(
e1
,
e2
)
->
Pair
(
eval
env
e1
,
eval
env
e2
)
|
Typed
.
Xml
(
e1
,
{
Typed
.
exp_descr
=
Typed
.
Pair
(
e2
,
e3
)
})
->
Xml
(
eval
env
e1
,
eval
env
e2
,
eval
env
e3
)
|
Typed
.
Xml
(
_
,_
)
->
assert
false
|
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
a
rg
)
|
Typed
.
Xtrans
(
arg
,
brs
)
->
eval_xtrans
env
brs
(
eval
env
arg
)
|
Typed
.
Try
(
arg
,
brs
)
->
eval_try
env
arg
brs
|
Typed
.
Transform
(
arg
,
brs
)
->
eval_transform
env
brs
(
eval
env
arg
)
|
Typed
.
Dot
(
e
,
l
)
->
eval_dot
l
(
eval
env
e
)
|
Typed
.
RemoveField
(
e
,
l
)
->
eval_remove_field
l
(
eval
env
e
)
|
Typed
.
UnaryOp
(
o
,
e
)
->
o
.
Typed
.
un_
op_eval
(
eval
env
e
)
|
Typed
.
BinaryOp
(
o
,
e1
,
e2
)
->
o
.
Typed
.
bin_op_eval
(
eval
env
e1
)
(
eval
env
e2
)
and
eval_try
env
arg
brs
=
try
eval
env
arg
with
(
CDuceExn
v
)
as
exn
->
match
eval_branches
env
brs
v
with
|
Value
.
Absent
->
raise
exn
|
x
->
x
and
eval_abstraction
env
a
=
let
env
=
IdSet
.
fold
(
fun
accu
x
->
try
Env
.
add
x
(
Env
.
find
x
env
)
accu
with
Not_found
->
accu
)
Env
.
empty
a
.
Typed
.
fun_fv
in
let
env_ref
=
ref
env
in
let
self
=
Abstraction
(
a
.
Typed
.
fun_iface
,
eval_branches
'
env
_ref
a
.
Typed
.
fun_body
)
in
(
match
a
.
Typed
.
fun_name
with
|
None
->
(
)
|
Some
f
->
env_ref
:=
Env
.
add
f
self
env
;
)
;
self
and
eval_apply
f
arg
=
match
f
with
...
...
@@ -72,9 +72,10 @@ and eval_branches env brs arg =
match
rhs
.
(
code
)
with
|
Patterns
.
Compile
.
Match
(
bind
,
e
)
->
let
env
=
List
.
fold_left
(
fun
env
(
x
,
i
)
->
if
(
i
==
-
1
)
then
Env
.
add
x
arg
env
else
Env
.
add
x
bindings
.
(
i
)
env
)
env
(
IdMap
.
get
bind
)
in
List
.
fold_left
(
fun
env
(
x
,
i
)
->
if
(
i
==
-
1
)
then
Env
.
add
x
arg
env
else
Env
.
add
x
bindings
.
(
i
)
env
)
env
(
IdMap
.
get
bind
)
in
eval
env
e
|
Patterns
.
Compile
.
Fail
->
Value
.
Absent
...
...
@@ -82,7 +83,9 @@ and eval_let_decl env l =
let
v
=
eval
env
l
.
Typed
.
let_body
in
let
(
disp
,
bind
)
=
Typed
.
dispatcher_let_decl
l
in
let
(
_
,
bindings
)
=
run_dispatcher
disp
v
in
List
.
map
(
fun
(
x
,
i
)
->
(
x
,
if
(
i
==
-
1
)
then
v
else
bindings
.
(
i
)))
(
IdMap
.
get
bind
)
List
.
map
(
fun
(
x
,
i
)
->
(
x
,
if
(
i
==
-
1
)
then
v
else
bindings
.
(
i
)))
(
IdMap
.
get
bind
)
and
eval_map
env
brs
=
function
|
Pair
(
x
,
y
)
->
...
...
@@ -95,7 +98,10 @@ and eval_map env brs = function
and
eval_transform
env
brs
=
function
|
Pair
(
x
,
y
)
->
let
x
=
match
eval_branches
env
brs
x
with
Value
.
Absent
->
Value
.
nil
|
x
->
x
in
let
x
=
match
eval_branches
env
brs
x
with
|
Value
.
Absent
->
Value
.
nil
|
x
->
x
in
concat
x
(
eval_transform
env
brs
y
)
|
String_latin1
(
_
,_,_,
q
)
|
String_utf8
(
_
,_,_,
q
)
as
v
->
if
Types
.
Char
.
is_empty
(
brs
.
Typed
.
br_accept
)
...
...
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