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
f00863af
Commit
f00863af
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2003-06-17 05:33:21 by cvscast] Clean -- Alain
Original author: cvscast Date: 2003-06-17 05:33:21+00:00
parent
50a2cf01
Changes
1
Hide whitespace changes
Inline
Side-by-side
runtime/eval.ml
View file @
f00863af
...
...
@@ -5,17 +5,13 @@ open Ident
exception
MultipleDeclaration
of
id
type
env
=
t
Env
.
t
(*
Evaluation of express
ion
s
*)
(*
To write tail-recursive map-like iterat
ion *)
let
make_accu
()
=
Pair
(
nil
,
Absent
)
let
get_accu
a
=
snd
(
Obj
.
magic
a
)
let
map
f
v
=
let
acc0
=
make_accu
()
in
set_cdr
(
f
acc0
v
)
nil
;
get_accu
acc0
let
map
f
v
=
let
acc0
=
make_accu
()
in
set_cdr
(
f
acc0
v
)
nil
;
get_accu
acc0
let
dummy
()
=
Absent
(* Evaluation of expressions *)
let
rec
eval
env
e0
=
match
e0
.
Typed
.
exp_descr
with
|
Typed
.
Forget
(
e
,_
)
->
eval
env
e
...
...
@@ -75,9 +71,6 @@ and eval_apply f arg = match f with
|
Abstraction
(
_
,
clos
)
->
clos
arg
|
_
->
assert
false
and
eval_branches'
env_ref
brs
arg
=
eval_branches
!
env_ref
brs
arg
and
eval_branches
env
brs
arg
=
let
(
disp
,
rhs
)
=
Typed
.
dispatcher
brs
in
let
(
code
,
bindings
)
=
run_dispatcher
disp
arg
in
...
...
@@ -114,16 +107,6 @@ and eval_rec_funs env l =
env
slots
in
List
.
map
(
fun
(
f
,
e
,
s
)
->
s
:=
eval
env'
e
;
(
f
,
!
s
))
slots
(*
and eval_map env brs = function
| Pair (x,y) ->
let x = eval_branches env brs x in
Pair (x, eval_map env brs y)
| String_latin1 (_,_,_,_) | String_utf8 (_,_,_,_) as v ->
eval_map env brs (normalize v)
| q -> q
*)
and
eval_map
env
brs
v
=
map
(
eval_map_aux
env
brs
)
v
...
...
@@ -137,31 +120,14 @@ and eval_map_aux env brs acc = function
eval_map_aux
env
brs
acc
(
normalize
v
)
|
_
->
acc
(*
and eval_transform env brs = function
| Pair (x,y) ->
(match eval_branches env brs x with
| Value.Absent -> eval_transform env brs y
| x -> concat x (eval_transform env brs y))
| String_latin1 (_,_,_,q) | String_utf8 (_,_,_,q) as v ->
if Types.Char.is_empty (brs.Typed.br_accept)
then eval_transform env brs q
else eval_transform env brs (normalize v)
| q -> q
*)
and
eval_transform
env
brs
v
=
map
(
eval_transform_aux
env
brs
)
v
and
eval_transform_aux
env
brs
acc
=
function
|
Pair
(
x
,
y
)
->
let
acc
=
match
eval_branches
env
brs
x
with
|
Value
.
Absent
->
acc
|
x
->
append_cdr
acc
x
(* Need to copy in general; optimization: detect fresh
constructors ... *)
let
acc
=
match
eval_branches
env
brs
x
with
|
Value
.
Absent
->
acc
|
x
->
append_cdr
acc
x
in
eval_transform_aux
env
brs
acc
y
|
String_latin1
(
_
,_,_,
q
)
|
String_utf8
(
_
,_,_,
q
)
as
v
->
...
...
@@ -170,32 +136,6 @@ and eval_transform_aux env brs acc = function
else
eval_transform_aux
env
brs
acc
(
normalize
v
)
|
_
->
acc
(*
and eval_xtrans env brs = function
| String_utf8 (s,i,j,q) as v ->
if Types.Char.is_empty (brs.Typed.br_accept)
then String_utf8 (s,i,j, eval_xtrans env brs q)
else eval_xtrans env brs (normalize v)
| String_latin1 (s,i,j,q) as v ->
if Types.Char.is_empty (brs.Typed.br_accept)
then String_latin1 (s,i,j, eval_xtrans env brs q)
else eval_xtrans env brs (normalize v)
| Pair (x,y) ->
(match eval_branches env brs x with
| Absent ->
let x = match x with
| Xml (tag, attr, child) ->
let child = eval_xtrans env brs child in
Xml (tag, attr, child)
| x -> x in
let y = eval_xtrans env brs y in
Pair (x,y)
| x ->
let y = eval_xtrans env brs y in
concat x y)
| q -> q
*)
and
eval_xtrans
env
brs
v
=
map
(
eval_xtrans_aux
env
brs
)
v
...
...
@@ -232,8 +172,6 @@ and eval_xtrans_aux env brs acc = function
eval_xtrans_aux
env
brs
acc
y
|
_
->
acc
and
eval_dot
l
=
function
|
Record
r
->
LabelMap
.
assoc
l
r
|
_
->
assert
false
...
...
@@ -241,3 +179,53 @@ and eval_dot l = function
and
eval_remove_field
l
=
function
|
Record
r
->
Record
(
LabelMap
.
remove
l
r
)
|
_
->
assert
false
(* Non tail-rec version:
and eval_transform env brs = function
| Pair (x,y) ->
(match eval_branches env brs x with
| Value.Absent -> eval_transform env brs y
| x -> concat x (eval_transform env brs y))
| String_latin1 (_,_,_,q) | String_utf8 (_,_,_,q) as v ->
if Types.Char.is_empty (brs.Typed.br_accept)
then eval_transform env brs q
else eval_transform env brs (normalize v)
| q -> q
and eval_xtrans env brs = function
| String_utf8 (s,i,j,q) as v ->
if Types.Char.is_empty (brs.Typed.br_accept)
then String_utf8 (s,i,j, eval_xtrans env brs q)
else eval_xtrans env brs (normalize v)
| String_latin1 (s,i,j,q) as v ->
if Types.Char.is_empty (brs.Typed.br_accept)
then String_latin1 (s,i,j, eval_xtrans env brs q)
else eval_xtrans env brs (normalize v)
| Pair (x,y) ->
(match eval_branches env brs x with
| Absent ->
let x = match x with
| Xml (tag, attr, child) ->
let child = eval_xtrans env brs child in
Xml (tag, attr, child)
| x -> x in
let y = eval_xtrans env brs y in
Pair (x,y)
| x ->
let y = eval_xtrans env brs y in
concat x y)
| q -> q
and eval_map env brs = function
| Pair (x,y) ->
let x = eval_branches env brs x in
Pair (x, eval_map env brs y)
| String_latin1 (_,_,_,_) | String_utf8 (_,_,_,_) as v ->
eval_map env brs (normalize v)
| q -> q
*)
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