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
6e644519
Commit
6e644519
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2003-09-27 22:49:09 by cvscast] alternative evaluator (--compile)
Original author: cvscast Date: 2003-09-27 22:49:09+00:00
parent
bb3efc53
Changes
10
Hide whitespace changes
Inline
Side-by-side
Makefile.distrib
View file @
6e644519
...
...
@@ -92,10 +92,11 @@ OBJECTS = \
\
typing/typed.cmo typing/typer.cmo
\
\
compile/lambda.cmo
compile/compile.cmo
\
compile/lambda.cmo
\
\
runtime/load_xml.cmo runtime/run_dispatch.cmo
\
runtime/print_xml.cmo runtime/eval.cmo
\
compile/compile.cmo
\
compile/operators.cmo
\
\
types/builtin.cmo driver/cduce.cmo
...
...
compile/compile.ml
View file @
6e644519
...
...
@@ -8,30 +8,47 @@ type env = {
let
empty
=
{
vars
=
Env
.
empty
;
stack_size
=
0
}
let
rec
compile
env
e
=
compile_aux
env
e
.
Typed
.
exp_descr
and
compile_aux
env
=
function
|
Typed
.
Forget
(
e
,_
)
->
compile
env
e
|
Typed
.
Var
x
->
Var
(
Env
.
find
x
env
.
vars
)
|
Typed
.
Apply
(
e1
,
e2
)
->
Apply
(
compile
env
e1
,
compile
env
e2
)
let
find
x
env
=
try
Env
.
find
x
env
.
vars
with
Not_found
->
failwith
(
"Compile: cannot find "
^
(
Ident
.
to_string
x
))
let
rec
compile
env
tail
e
=
compile_aux
env
tail
e
.
Typed
.
exp_descr
and
compile_aux
env
tail
=
function
|
Typed
.
Forget
(
e
,_
)
->
compile
env
tail
e
|
Typed
.
Var
x
->
Var
(
find
x
env
)
|
Typed
.
Apply
(
e1
,
e2
)
->
Apply
(
tail
,
compile
env
false
e1
,
compile
env
tail
e2
)
|
Typed
.
Abstraction
a
->
compile_abstr
env
a
|
Typed
.
Cst
c
->
Const
c
|
Typed
.
Pair
(
e1
,
e2
)
->
Pair
(
compile
env
e1
,
compile
env
e2
)
|
Typed
.
Pair
(
e1
,
e2
)
->
Pair
(
compile
env
false
e1
,
compile
env
tail
e2
)
|
Typed
.
Xml
(
e1
,
{
Typed
.
exp_descr
=
Typed
.
Pair
(
e2
,
e3
)
})
->
let
env'
=
env
in
Xml
(
compile
env
e1
,
compile
env'
e2
,
compile
env'
e3
)
Xml
(
compile
env
false
e1
,
compile
env
false
e2
,
compile
env
tail
e3
)
|
Typed
.
Xml
(
_
,_
)
->
assert
false
|
Typed
.
RecordLitt
r
->
Record
(
LabelMap
.
map
(
compile
env
)
r
)
|
Typed
.
String
(
i
,
j
,
s
,
q
)
->
String
(
i
,
j
,
s
,
compile
env
q
)
|
Typed
.
Match
(
e
,
brs
)
->
Match
(
compile
env
e
,
compile_branches
env
brs
)
|
_
->
assert
false
|
Typed
.
RecordLitt
r
->
Record
(
LabelMap
.
map
(
compile
env
false
)
r
)
|
Typed
.
String
(
i
,
j
,
s
,
q
)
->
String
(
i
,
j
,
s
,
compile
env
tail
q
)
|
Typed
.
Match
(
e
,
brs
)
->
Match
(
compile
env
false
e
,
compile_branches
env
tail
brs
)
|
Typed
.
Map
(
e
,
brs
)
->
Map
(
compile
env
false
e
,
compile_branches
env
false
brs
)
|
Typed
.
Transform
(
e
,
brs
)
->
Transform
(
compile
env
false
e
,
compile_branches
env
false
brs
)
|
Typed
.
Xtrans
(
e
,
brs
)
->
Xtrans
(
compile
env
false
e
,
compile_branches
env
false
brs
)
|
Typed
.
Validate
(
e
,
sch
,
t
)
->
Validate
(
compile
env
tail
e
,
sch
,
t
)
|
Typed
.
RemoveField
(
e
,
l
)
->
RemoveField
(
compile
env
tail
e
,
l
)
|
Typed
.
Dot
(
e
,
l
)
->
Dot
(
compile
env
tail
e
,
l
)
|
Typed
.
Try
(
e
,
brs
)
->
Try
(
compile
env
false
e
,
compile_branches
env
tail
brs
)
|
Typed
.
UnaryOp
(
op
,
e
)
->
UnaryOp
(
op
,
compile
env
tail
e
)
|
Typed
.
BinaryOp
(
op
,
e1
,
e2
)
->
BinaryOp
(
op
,
compile
env
false
e1
,
compile
env
tail
e2
)
|
Typed
.
Ref
(
e
,
t
)
->
Ref
(
compile
env
tail
e
,
t
)
and
compile_abstr
env
a
=
let
fun_env
=
match
a
.
Typed
.
fun_name
with
|
Some
x
->
Env
.
add
x
(
Env
0
)
Env
.
empty
|
None
->
Env
.
empty
in
let
(
slots
,
nb_slots
,
fun_env
)
=
List
.
fold_left
(
fun
(
slots
,
nb_slots
,
fun_env
)
x
->
match
Env
.
find
x
env
.
vars
with
match
find
x
env
with
|
(
Stack
_
|
Env
_
)
as
p
->
p
::
slots
,
succ
nb_slots
,
...
...
@@ -42,30 +59,56 @@ and compile_abstr env a =
Env
.
add
x
p
fun_env
|
Dummy
->
assert
false
)
([
]
,
0
,
Env
.
empty
)
(
IdSet
.
get
a
.
Typed
.
fun_fv
)
in
([
Dummy
]
,
1
,
fun_env
)
(
IdSet
.
get
a
.
Typed
.
fun_fv
)
in
let
recurs
,
fun_env
,
slots
=
match
a
.
Typed
.
fun_name
with
|
Some
x
when
IdSet
.
mem
a
.
Typed
.
fun_fv
x
->
true
,
Env
.
add
x
(
Env
0
)
fun_env
,
Dummy
::
slots
|
_
->
false
,
fun_env
,
slots
in
let
slots
=
Array
.
of_list
(
List
.
rev
slots
)
in
let
env
=
{
vars
=
fun_env
;
stack_size
=
0
}
in
let
body
=
compile_branches
env
a
.
Typed
.
fun_body
in
Abstraction
(
recurs
,
slots
,
a
.
Typed
.
fun_iface
,
body
)
let
body
=
compile_branches
env
true
a
.
Typed
.
fun_body
in
Abstraction
(
slots
,
a
.
Typed
.
fun_iface
,
body
)
and
compile_branches
env
(
brs
:
Typed
.
branches
)
=
and
compile_branches
env
tail
(
brs
:
Typed
.
branches
)
=
{
brs
=
List
.
map
(
compile_branch
env
)
brs
.
Typed
.
br_branches
;
brs
=
List
.
map
(
compile_branch
env
tail
)
brs
.
Typed
.
br_branches
;
brs_tail
=
tail
;
brs_accept_chars
=
not
(
Types
.
Char
.
is_empty
brs
.
Typed
.
br_accept
);
brs_input
=
brs
.
Typed
.
br_typ
;
brs_compiled
=
None
}
and
compile_branch
env
br
=
and
compile_branch
env
tail
br
=
let
env
=
List
.
fold_left
(
fun
env
x
->
{
vars
=
Env
.
add
x
(
Stack
env
.
stack_size
)
env
.
vars
;
stack_size
=
env
.
stack_size
+
1
}
)
env
(
IdSet
.
get
(
Patterns
.
fv
br
.
Typed
.
br_pat
))
in
(
br
.
Typed
.
br_pat
,
compile
env
br
.
Typed
.
br_body
)
(
br
.
Typed
.
br_pat
,
compile
env
tail
br
.
Typed
.
br_body
)
let
enter_global
env
x
=
{
vars
=
Env
.
add
x
(
Global
env
.
stack_size
)
env
.
vars
;
stack_size
=
env
.
stack_size
+
1
}
let
enter_globals
=
List
.
fold_left
enter_global
let
compile_let_decl
env
decl
=
let
pat
=
decl
.
Typed
.
let_pat
in
let
decl
=
{
let_pat
=
pat
;
let_expr
=
compile
env
false
(
decl
.
Typed
.
let_body
)
}
in
let
names
=
IdSet
.
get
(
Patterns
.
fv
pat
)
in
let
env
=
enter_globals
env
names
in
(
names
,
env
,
decl
)
let
compile_rec_funs
env
funs
=
let
fun_name
=
function
|
{
Typed
.
exp_descr
=
Typed
.
Abstraction
{
Typed
.
fun_name
=
Some
x
}}
->
x
|
_
->
assert
false
in
let
fun_a
=
function
|
{
Typed
.
exp_descr
=
Typed
.
Abstraction
a
}
->
a
|
_
->
assert
false
in
let
names
=
List
.
map
fun_name
funs
in
let
env
=
enter_globals
env
names
in
let
exprs
=
List
.
map
(
compile_abstr
env
)
(
List
.
map
fun_a
funs
)
in
(
names
,
env
,
exprs
)
compile/lambda.ml
View file @
6e644519
...
...
@@ -9,8 +9,8 @@ type var_loc =
type
expr
=
|
Var
of
var_loc
|
Apply
of
expr
*
expr
|
Abstraction
of
bool
*
var_loc
array
*
(
Types
.
t
*
Types
.
t
)
list
*
branches
|
Apply
of
bool
*
expr
*
expr
|
Abstraction
of
var_loc
array
*
(
Types
.
t
*
Types
.
t
)
list
*
branches
|
Const
of
Types
.
Const
.
t
|
Pair
of
expr
*
expr
...
...
@@ -26,64 +26,20 @@ type expr =
|
RemoveField
of
expr
*
label
|
Dot
of
expr
*
label
|
Try
of
expr
*
branches
|
UnaryOp
of
unary_op
*
expr
|
BinaryOp
of
binary_op
*
expr
|
Ref
of
expr
*
Types
.
t
and
unary_op
=
id
and
binary_op
=
id
|
UnaryOp
of
int
*
expr
|
BinaryOp
of
int
*
expr
*
expr
|
Ref
of
expr
*
Types
.
Node
.
t
and
branches
=
{
brs
:
(
Patterns
.
node
*
expr
)
list
;
brs_tail
:
bool
;
brs_input
:
Types
.
t
;
brs_accept_chars
:
bool
;
mutable
brs_compiled
:
(
Patterns
.
Compile
.
dispatcher
*
expr
Patterns
.
Compile
.
rhs
array
)
option
}
(*
(* Evaluator *)
let call_stack = ref []
let env = ref [| |]
let stack = ref (Array.create 1024 Value.Absent)
let global = ref (Array.create 1024 Value.Absent)
let frame = ref 0
let sp = ref 0
let set a i x =
let n = Array.length !a in
if i = n then (
let b = Array.create (n*2) Value.Absent in
Array.blit !a 0 b 0 n;
a := b
);
!a.(i) <- x
let eval_var env = function
| Env i -> env.(i)
| Global i -> !global.(i)
| Stack i -> !stack.(!frame + i)
| Dummy -> Value.Absent
let rec eval env = function
| Var x -> eval_var env x
| Apply (e1,e2) -> eval_apply (eval env e1) (eval env e2)
| Abstraction (recurs,slots,iface,body) ->
if recurs then
let local_env = Array.map (eval_var env) slots in
let a = Value.Abstraction (local_env,iface,body) in
local_env.(Array.length local_env - 1) <- a;
a
else
let local_env = Array.map eval_var slots in
Value.Abstraction (local_env,iface,body)
and eval_apply f arg =
match f with
| Value.Abstraction (local_env,_,body) -> eval_branches local_env body arg
| _ -> assert false
*)
type
let_decl
=
{
let_pat
:
Patterns
.
node
;
let_expr
:
expr
;
}
depend
View file @
6e644519
...
...
@@ -128,8 +128,10 @@ typing/typer.cmx: misc/q_symbol.cmo parser/ast.cmx types/atoms.cmx types/builtin
types/types.cmx typing/typer.cmi
compile/lambda.cmo: misc/q_symbol.cmo types/ident.cmo types/patterns.cmi types/types.cmi
compile/lambda.cmx: misc/q_symbol.cmo types/ident.cmx types/patterns.cmx types/types.cmx
compile/compile.cmo: misc/q_symbol.cmo types/patterns.cmi typing/typed.cmo
compile/compile.cmx: misc/q_symbol.cmo types/patterns.cmx typing/typed.cmx
compile/compile.cmo: misc/q_symbol.cmo types/ident.cmo compile/lambda.cmo types/patterns.cmi \
typing/typed.cmo runtime/value.cmi
compile/compile.cmx: misc/q_symbol.cmo types/ident.cmx compile/lambda.cmx types/patterns.cmx \
typing/typed.cmx runtime/value.cmx
runtime/load_xml.cmo: misc/q_symbol.cmo types/atoms.cmi misc/encodings.cmi types/ident.cmo \
parser/location.cmi misc/ns.cmi runtime/value.cmi runtime/load_xml.cmi
runtime/load_xml.cmx: misc/q_symbol.cmo types/atoms.cmx misc/encodings.cmx types/ident.cmx \
...
...
@@ -168,22 +170,22 @@ types/builtin.cmx: misc/q_symbol.cmo types/atoms.cmx types/builtin_defs.cmx type
parser/location.cmx misc/ns.cmx compile/operators.cmx \
runtime/print_xml.cmx types/sequence.cmx typing/typer.cmx types/types.cmx \
runtime/value.cmx types/builtin.cmi
driver/cduce.cmo: misc/q_symbol.cmo parser/ast.cmo types/builtin.cmi
runtime/eval
.cm
i
\
types/ident.cmo parser/location.cmi misc/ns.cmi
parser/parser.cmi
\
types/patterns.cmi types/sample.cmi misc/state.cmi
typing/typed.cmo
\
typing/typer.cmi types/types.cmi parser/ulexer.cmi
runtime/value.cmi
\
driver/cduce.cmi
driver/cduce.cmx: misc/q_symbol.cmo parser/ast.cmx types/builtin.cmx
runtime/eval
.cmx \
types/ident.cmx parser/location.cmx misc/ns.cmx
parser/parser.cmx
\
types/patterns.cmx types/sample.cmx misc/state.cmx
typing/typed.cmx
\
typing/typer.cmx types/types.cmx parser/ulexer.cmx
runtime/value.cmx
\
driver/cduce.cmi
driver/cduce.cmo: misc/q_symbol.cmo parser/ast.cmo types/builtin.cmi
compile/compile
.cm
o
\
runtime/eval.cmi
types/ident.cmo parser/location.cmi misc/ns.cmi \
parser/parser.cmi
types/patterns.cmi types/sample.cmi misc/state.cmi \
typing/typed.cmo
typing/typer.cmi types/types.cmi parser/ulexer.cmi \
runtime/value.cmi
driver/cduce.cmi
driver/cduce.cmx: misc/q_symbol.cmo parser/ast.cmx types/builtin.cmx
compile/compile
.cmx \
runtime/eval.cmx
types/ident.cmx parser/location.cmx misc/ns.cmx \
parser/parser.cmx
types/patterns.cmx types/sample.cmx misc/state.cmx \
typing/typed.cmx
typing/typer.cmx types/types.cmx parser/ulexer.cmx \
runtime/value.cmx
driver/cduce.cmi
driver/run.cmo: misc/q_symbol.cmo driver/cduce.cmi types/ident.cmo runtime/load_xml.cmi \
parser/location.cmi types/sequence.cmi misc/s
erializ
e.cmi misc/stat
e
.cmi \
misc/stats.cmi
parser/ulexer.cmi runtime/value.cmi
parser/location.cmi types/sequence.cmi misc/s
tat
e.cmi misc/stat
s
.cmi \
parser/ulexer.cmi runtime/value.cmi
driver/run.cmx: misc/q_symbol.cmo driver/cduce.cmx types/ident.cmx runtime/load_xml.cmx \
parser/location.cmx types/sequence.cmx misc/s
erializ
e.cmx misc/stat
e
.cmx \
misc/stats.cmx
parser/ulexer.cmx runtime/value.cmx
parser/location.cmx types/sequence.cmx misc/s
tat
e.cmx misc/stat
s
.cmx \
parser/ulexer.cmx runtime/value.cmx
driver/webiface.cmo: misc/q_symbol.cmo driver/cduce.cmi driver/examples.cmo parser/location.cmi \
misc/state.cmi
driver/webiface.cmx: misc/q_symbol.cmo driver/cduce.cmx driver/examples.cmx parser/location.cmx \
...
...
driver/cduce.ml
View file @
6e644519
...
...
@@ -6,11 +6,25 @@ let toplevel = ref false
let
typing_env
=
State
.
ref
"Cduce.typing_env"
Builtin
.
env
let
eval_env
=
State
.
ref
"Cduce.eval_env"
Env
.
empty
let
compile_env
=
State
.
ref
"Cduce.compile_env"
Compile
.
empty
let
do_compile
=
ref
false
let
get_global_value
v
=
if
!
do_compile
then
Eval
.
L
.
eval_var
(
Compile
.
find
v
!
compile_env
)
else
Env
.
find
v
!
eval_env
let
get_global_type
v
=
Typer
.
find_value
v
!
typing_env
let
enter_global_value
x
v
t
=
eval_env
:=
Env
.
add
x
v
!
eval_env
;
typing_env
:=
Typer
.
enter_value
x
t
!
typing_env
typing_env
:=
Typer
.
enter_value
x
t
!
typing_env
;
if
!
do_compile
then
(
compile_env
:=
Compile
.
enter_global
!
compile_env
x
;
Eval
.
L
.
push
v
)
else
eval_env
:=
Env
.
add
x
v
!
eval_env
let
rec
is_abstraction
=
function
|
Ast
.
Abstraction
_
->
true
|
Ast
.
LocatedExpr
(
_
,
e
)
->
is_abstraction
e
...
...
@@ -42,7 +56,8 @@ let dump_env ppf =
Format
.
fprintf
ppf
"@[val %a : @[%a = %a@]@]@."
U
.
print
(
Id
.
value
x
)
print_norm
t
print_value
v
)
!
eval_env
!
eval_env
;
Eval
.
L
.
dump
ppf
let
rec
print_exn
ppf
=
function
|
Location
(
loc
,
w
,
exn
)
->
...
...
@@ -140,6 +155,15 @@ let insert_bindings ppf =
if
not
!
quiet
then
Format
.
fprintf
ppf
"val %a : @[@[%a@] =@ @[%a@]@]@."
U
.
print
(
Id
.
value
x
)
print_norm
t
print_value
v
)
let
display
ppf
=
List
.
iter
(
fun
x
->
let
t
=
get_global_type
x
in
let
v
=
get_global_value
x
in
if
not
!
quiet
then
Format
.
fprintf
ppf
"val %a : @[@[%a@] =@ @[%a@]@]@."
U
.
print
(
Id
.
value
x
)
print_norm
t
print_value
v
)
let
rec
collect_funs
ppf
accu
=
function
|
{
descr
=
Ast
.
FunDecl
e
}
::
rest
->
...
...
@@ -148,8 +172,17 @@ let rec collect_funs ppf accu = function
|
rest
->
let
typs
=
Typer
.
type_rec_funs
!
typing_env
accu
in
Typer
.
report_unused_branches
()
;
let
vals
=
Eval
.
eval_rec_funs
!
eval_env
accu
in
insert_bindings
ppf
typs
vals
;
if
!
do_compile
then
let
(
names
,
env
,
funs
)
=
Compile
.
compile_rec_funs
!
compile_env
accu
in
Eval
.
L
.
eval_rec_funs
funs
;
typing_env
:=
Typer
.
enter_values
typs
!
typing_env
;
compile_env
:=
env
;
display
ppf
names
else
(
let
vals
=
Eval
.
eval_rec_funs
!
eval_env
accu
in
insert_bindings
ppf
typs
vals
);
rest
let
rec
collect_types
ppf
accu
=
function
...
...
@@ -175,18 +208,38 @@ let rec phrases ppf phs = match phs with
let
(
fv
,
e
)
=
Typer
.
expr
!
typing_env
e
in
let
t
=
Typer
.
type_check
!
typing_env
e
Types
.
any
true
in
Typer
.
report_unused_branches
()
;
if
not
!
quiet
then
Location
.
dump_loc
ppf
(
e
.
Typed
.
exp_loc
,
`Full
);
let
v
=
Eval
.
eval
!
eval_env
e
in
if
not
!
quiet
then
Format
.
fprintf
ppf
"- : @[@[%a@] =@ @[%a@]@]@."
print_norm
t
print_value
v
;
if
!
do_compile
then
let
e
=
Compile
.
compile
!
compile_env
false
e
in
let
v
=
Eval
.
L
.
eval
e
in
if
not
!
quiet
then
Format
.
fprintf
ppf
"- : @[@[%a@] =@ @[%a@]@]@."
print_norm
t
print_value
v
;
else
(
let
v
=
Eval
.
eval
!
eval_env
e
in
if
not
!
quiet
then
Format
.
fprintf
ppf
"- : @[@[%a@] =@ @[%a@]@]@."
print_norm
t
print_value
v
);
phrases
ppf
rest
|
{
descr
=
Ast
.
LetDecl
(
p
,
e
)
}
::
rest
->
let
decl
=
Typer
.
let_decl
!
typing_env
p
e
in
let
typs
=
Typer
.
type_let_decl
!
typing_env
decl
in
Typer
.
report_unused_branches
()
;
let
vals
=
Eval
.
eval_let_decl
!
eval_env
decl
in
insert_bindings
ppf
typs
vals
;
if
!
do_compile
then
let
(
names
,
env
,
decl
)
=
Compile
.
compile_let_decl
!
compile_env
decl
in
Eval
.
L
.
eval_let_decl
decl
;
typing_env
:=
Typer
.
enter_values
typs
!
typing_env
;
compile_env
:=
env
;
display
ppf
names
else
(
let
vals
=
Eval
.
eval_let_decl
!
eval_env
decl
in
insert_bindings
ppf
typs
vals
);
phrases
ppf
rest
|
{
descr
=
Ast
.
Debug
l
}
::
rest
->
debug
ppf
l
;
...
...
driver/cduce.mli
View file @
6e644519
val
quiet
:
bool
ref
val
toplevel
:
bool
ref
val
do_compile
:
bool
ref
val
enter_global_value
:
Ident
.
id
->
Value
.
t
->
Types
.
descr
->
unit
val
script
:
Format
.
formatter
->
Format
.
formatter
->
char
Stream
.
t
->
bool
...
...
driver/run.ml
View file @
6e644519
...
...
@@ -32,6 +32,8 @@ let specs =
" specify persistency file for loading and saving"
;
"--quiet"
,
Arg
.
Set
Cduce
.
quiet
,
" suppress normal output (typing, results)"
;
"--compile"
,
Arg
.
Set
Cduce
.
do_compile
,
" activate compilation"
;
"--stdin"
,
Arg
.
Unit
(
fun
()
->
src
:=
""
::
!
src
)
,
" read CDuce script on standard input"
;
"--verbose"
,
Arg
.
Unit
(
fun
()
->
Stats
.
set_verbosity
Stats
.
Summary
)
,
...
...
runtime/eval.ml
View file @
6e644519
...
...
@@ -245,3 +245,276 @@ and eval_map env brs = function
*)
(* Evaluator for "compiled" expressions *)
module
L
=
struct
open
Lambda
let
dispatcher
brs
=
match
brs
.
brs_compiled
with
|
Some
d
->
d
|
None
->
let
x
=
Patterns
.
Compile
.
make_branches
brs
.
brs_input
brs
.
brs
in
brs
.
brs_compiled
<-
Some
x
;
x
let
stack
=
ref
(
Array
.
create
1024
Value
.
Absent
)
let
frame
=
ref
0
let
sp
=
ref
0
let
dump
ppf
=
Format
.
fprintf
ppf
"sp = %i frame = %i@."
!
sp
!
frame
;
for
i
=
0
to
!
sp
-
1
do
if
i
=
!
frame
then
Format
.
fprintf
ppf
"FRAME@."
;
Format
.
fprintf
ppf
"%a@."
Value
.
print
!
stack
.
(
i
)
done
let
ensure
a
i
=
let
n
=
Array
.
length
!
a
in
if
i
=
n
then
(
let
b
=
Array
.
create
(
max
(
n
*
2
)
i
)
Value
.
Absent
in
Array
.
blit
!
a
0
b
0
n
;
a
:=
b
)
let
set
a
i
x
=
ensure
a
i
;
!
a
.
(
i
)
<-
x
let
push
x
=
set
stack
!
sp
x
;
incr
sp
let
calls
=
ref
0
let
eval_var
env
=
function
|
Env
i
->
env
.
(
i
)
|
Global
i
->
!
stack
.
(
i
)
|
Stack
i
->
!
stack
.
(
!
frame
+
i
)
|
Dummy
->
Value
.
Absent
let
rec
eval
env
=
function
|
Var
x
->
eval_var
env
x
|
Apply
(
false
,
e1
,
e2
)
->
let
v1
=
eval
env
e1
in
let
v2
=
eval
env
e2
in
eval_apply
v1
v2
|
Apply
(
true
,
e1
,
e2
)
->
let
v1
=
eval
env
e1
in
let
v2
=
eval
env
e2
in
eval_apply_tail_rec
v1
v2
|
Abstraction
(
slots
,
iface
,
body
)
->
eval_abstraction
env
slots
iface
body
|
Const
c
->
Value
.
const
c
|
Pair
(
e1
,
e2
)
->
let
v1
=
eval
env
e1
in
let
v2
=
eval
env
e2
in
Value
.
Pair
(
v1
,
v2
)
|
Xml
(
e1
,
e2
,
e3
)
->
let
v1
=
eval
env
e1
in
let
v2
=
eval
env
e2
in
let
v3
=
eval
env
e3
in
Value
.
Xml
(
v1
,
v2
,
v3
)
|
Record
r
->
Value
.
Record
(
LabelMap
.
map
(
eval
env
)
r
)
|
String
(
i
,
j
,
s
,
q
)
->
Value
.
String_utf8
(
i
,
j
,
s
,
eval
env
q
)
|
Match
(
e
,
brs
)
->
eval_branches
env
brs
(
eval
env
e
)
|
Map
(
arg
,
brs
)
->
eval_map
env
brs
(
eval
env
arg
)
|
Xtrans
(
arg
,
brs
)
->
eval_xtrans
env
brs
(
eval
env
arg
)
|
Try
(
arg
,
brs
)
->
eval_try
env
arg
brs
|
Transform
(
arg
,
brs
)
->
eval_transform
env
brs
(
eval
env
arg
)
|
Dot
(
e
,
l
)
->
eval_dot
l
(
eval
env
e
)
|
RemoveField
(
e
,
l
)
->
eval_remove_field
l
(
eval
env
e
)
|
UnaryOp
(
op
,
e
)
->
!
eval_unary_op
op
(
eval
env
e
)
|
BinaryOp
(
op
,
e1
,
e2
)
->
let
v1
=
eval
env
e1
in
let
v2
=
eval
env
e2
in
!
eval_binary_op
op
v1
v2
|
Validate
(
e
,
schema
,
name
)
->
eval_validate
env
e
schema
name
|
Ref
(
e
,
t
)
->
eval_ref
env
e
t
and
eval_abstraction
env
slots
iface
body
=
let
local_env
=
Array
.
map
(
eval_var
env
)
slots
in
let
a
=
Value
.
Abstraction2
(
local_env
,
iface
,
body
)
in
local_env
.
(
0
)
<-
a
;
a
and
eval_apply
f
arg
=
(* Format.fprintf Format.std_formatter
"Apply %i@." !calls;
incr calls;*)
match
f
with
|
Value
.
Abstraction2
(
local_env
,_,
body
)
->
let
saved_frame
=
!
frame
and
saved_sp
=
!
sp
in
frame
:=
!
sp
;
let
v
=
eval_branches
local_env
body
arg
in
frame
:=
saved_frame
;
sp
:=
saved_sp
;
v
|
Value
.
Abstraction
(
_
,
f
)
->
f
arg
|
_
->
assert
false
and
eval_apply_tail_rec
f
arg
=
(* Format.fprintf Format.std_formatter
"Apply tail %i@." !calls;
incr calls;*)
match
f
with
|
Value
.
Abstraction2
(
local_env
,_,
body
)
->
sp
:=
!
frame
;
eval_branches
local_env
body
arg
|
Value
.
Abstraction
(
_
,
f
)
->
f
arg
|
_
->
assert
false
and
eval_branches
env
brs
arg
=
let
(
disp
,
rhs
)
=
dispatcher
brs
in
let
(
code
,
bindings
)
=
Run_dispatch
.
run_dispatcher
disp
arg
in
match
rhs
.
(
code
)
with
|
Patterns
.
Compile
.
Match
(
bind
,
e
)
->
let
saved_sp
=
!
sp
in
IdMap
.
iter
(
fun
i
->
push
(
if
(
i
==
-
1
)
then
arg
else
bindings
.
(
i
)))
bind
;
if
brs
.
brs_tail
then
eval
env
e
else
let
v
=
eval
env
e
in
sp
:=
saved_sp
;
v
|
Patterns
.
Compile
.
Fail
->
Value
.
Absent
and
eval_ref
env
e
t
=
let
r
=
ref
(
eval
env
e
)
in
let
get
=
Value
.
Abstraction
([
Sequence
.
nil_type
,
Types
.
descr
t
]
,
fun
_
->
!
r
)
and
set
=
Value
.
Abstraction
([
Types
.
descr
t
,
Sequence
.
nil_type
]
,
fun
x
->
r
:=
x
;
nil
)
in
Value
.
Record
(
Builtin_defs
.
mk_ref
~
get
~
set
)
and
eval_validate
env
e
schema
name
=
let
validator
=
Typer
.
get_schema_validator
(
schema
,
name
)
in
Schema_validator
.
validate
~
validator
(
Schema_xml
.
pxp_stream_of_value
(
eval
env
e
))
and
eval_try
env
arg
brs
=
let
saved_frame
=
!
frame
and
saved_sp
=
!
sp
in
try
eval
env
arg
with
(
CDuceExn
v
)
as
exn
->
frame
:=
saved_frame
;
sp
:=
saved_sp
;
match
eval_branches
env
brs
v
with
|
Value
.
Absent
->
raise
exn
|
x
->
x
and
eval_map
env
brs
v
=
map
(
eval_map_aux
env
brs
)
v
and
eval_map_aux
env
brs
acc
=
function
|
Value
.
Pair
(
x
,
y
)
->
let
x
=
eval_branches
env
brs
x
in
let
acc'
=
Value
.
Pair
(
x
,
Absent
)
in
set_cdr
acc
acc'
;
eval_map_aux
env
brs
acc'
y
|
Value
.
String_latin1
(
_
,_,_,_
)
|
Value
.
String_utf8
(
_
,_,_,_
)
as
v
->
eval_map_aux
env
brs
acc
(
normalize
v
)
|
_
->
acc
and
eval_transform
env
brs
v
=
map
(
eval_transform_aux
env
brs
)
v
and
eval_transform_aux
env
brs
acc
=
function
|
Value
.
Pair
(
x
,
y
)
->
(
match
eval_branches
env
brs
x
with