Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
C
cduce
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
19
Issues
19
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Repository
Value Stream
Wiki
Wiki
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
cduce
cduce
Commits
103b0628
Commit
103b0628
authored
Oct 05, 2007
by
Pietro Abate
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[r2003-09-27 22:49:09 by cvscast] alternative evaluator (--compile)
Original author: cvscast Date: 2003-09-27 22:49:09+00:00
parent
65a0a855
Changes
10
Hide whitespace changes
Inline
Side-by-side
Showing
10 changed files
with
456 additions
and
110 deletions
+456
-110
Makefile.distrib
Makefile.distrib
+2
-1
compile/compile.ml
compile/compile.ml
+69
-26
compile/lambda.ml
compile/lambda.ml
+11
-55
depend
depend
+18
-16
driver/cduce.ml
driver/cduce.ml
+63
-10
driver/cduce.mli
driver/cduce.mli
+1
-0
driver/run.ml
driver/run.ml
+2
-0
runtime/eval.ml
runtime/eval.ml
+273
-0
runtime/eval.mli
runtime/eval.mli
+10
-0
typing/typer.ml
typing/typer.ml
+7
-2
No files found.
Makefile.distrib
View file @
103b0628
...
...
@@ -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 @
103b0628
...
...
@@ -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 @
103b0628
...
...
@@ -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 @
103b0628
...
...
@@ -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.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/type
r.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/type
r.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.cmo
\
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/type
d.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/type
d.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
erialize.cmi misc/state
.cmi \
misc/stats.cmi
parser/ulexer.cmi runtime/value.cmi
parser/location.cmi types/sequence.cmi misc/s
tate.cmi misc/stats
.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
erialize.cmx misc/state
.cmx \
misc/stats.cmx
parser/ulexer.cmx runtime/value.cmx
parser/location.cmx types/sequence.cmx misc/s
tate.cmx misc/stats
.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 @
103b0628
...
...
@@ -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 @
103b0628
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 @
103b0628
...
...
@@ -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 @
103b0628
...
...
@@ -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
|
Value
.
Absent
->
eval_transform_aux
env
brs
acc
y
|
x
->
eval_transform_aux
env
brs
(
append_cdr
acc
x
)
y
)
|
Value
.
String_latin1
(
_
,_,_,
q
)
|
Value
.
String_utf8
(
_
,_,_,
q
)
as
v
->
if
not
brs
.
brs_accept_chars
then
eval_transform_aux
env
brs
acc
v
else
eval_transform_aux
env
brs
acc
(
normalize
v
)
|
_
->
acc
and
eval_xtrans
env
brs
v
=
map
(
eval_xtrans_aux
env
brs
)
v
and
eval_xtrans_aux
env
brs
acc
=
function
|
Value
.
String_utf8
(
s
,
i
,
j
,
q
)
as
v
->
if
not
brs
.
brs_accept_chars
then
let
acc'
=
Value
.
String_utf8
(
s
,
i
,
j
,
Absent
)
in
set_cdr
acc
acc'
;
eval_xtrans_aux
env
brs
acc'
q
else
eval_xtrans_aux
env
brs
acc
(
normalize
v
)
|
Value
.
String_latin1
(
s
,
i
,
j
,
q
)
as
v
->
if
not
brs
.
brs_accept_chars
then
let
acc'
=
Value
.
String_latin1
(
s
,
i
,
j
,
Absent
)
in
set_cdr
acc
acc'
;
eval_xtrans_aux
env
brs
acc'
q