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
04247512
Commit
04247512
authored
Mar 28, 2014
by
Julien Lopez
Browse files
[TESTS][EVAL] Environment management done; remains only to define branches
parent
8fbfb47b
Changes
5
Hide whitespace changes
Inline
Side-by-side
tests/eval/src/compile.ml
View file @
04247512
...
...
@@ -2,7 +2,6 @@ open Printf
open
Parse
open
Lambda
open
Auto_pat
open
Value
let
page_size
=
1000
...
...
@@ -10,71 +9,65 @@ type env =
{
parent
:
env
option
;
(* None: toplevel *)
map
:
(
string
,
int
)
Hashtbl
.
t
;
locals
:
var_loc
array
;
max_size
:
int
;
actual_size
:
int
;
global_size
:
int
}
let
mk_env
?
parent
:
(
p
=
None
)
?
max_size
:
(
s
=
page_size
)
?
map
:
(
m
=
Hashtbl
.
create
s
)
?
locals
:
(
l
=
Array
.
make
s
Dummy
)
actual_size
global_size
=
{
parent
=
p
;
map
=
m
;
locals
=
l
;
max_size
=
s
;
actual_size
=
actual_size
;
global_size
=
global_size
}
a_size
g_size
=
{
parent
=
p
;
map
=
m
;
max_size
=
s
;
actual_size
=
a_size
;
global_size
=
g_size
}
let
parse_to_lambda
expr
=
(* TODO: Replace dummy_branches *)
let
rec
env_find
env
el
=
try
Hashtbl
.
find
env
.
map
el
with
Not_found
->
match
env
.
parent
with
|
Some
p
->
env_find
p
el
|
None
->
raise
Not_found
let
compile_branches
env
body
=
(* TODO: Replace dummy_branches *)
let
dummy_state
=
{
uid
=
0
;
arity
=
[
||
];
actions
=
AIgnore
(
0
,
[
||
]
,
0
);
fail_code
=
0
;
expected_type
=
""
}
in
let
dummy_branches
=
{
brs_accept_chars
=
true
;
brs_disp
=
dummy_state
;
brs_rhs
=
[
||
];
brs_stack_pos
=
0
}
in
dummy_branches
let
parse_to_lambda
expr
=
let
rec
_parse_to_lambda
env
expr
=
let
dummy_state
=
{
uid
=
0
;
arity
=
[
||
];
actions
=
AIgnore
(
0
,
[
||
]
,
0
);
fail_code
=
0
;
expected_type
=
""
}
in
let
dummy_branches
=
{
brs_accept_chars
=
true
;
brs_disp
=
dummy_state
;
brs_rhs
=
[
||
];
brs_stack_pos
=
0
}
in
match
expr
with
|
Parse
.
Apply
(
e1
,
e2
)
->
Apply
(
_parse_to_lambda
env
e1
,
_parse_to_lambda
env
e2
)
|
Abstract
(
fname
,
interface
,
body
)
->
let
map
=
Hashtbl
.
create
page_size
in
Hashtbl
.
add
map
fname
0
;
let
params
,
nbrparams
=
let
rec
fill_params
params
res
nbr
=
match
params
with
|
el
::
rest
->
let
curr
=
[
|
Local
(
0
)
|
]
in
(* TODO: Not supposed to be 0 *)
|
el
::
rest
->
Hashtbl
.
add
map
el
nbr
;
let
curr
=
[
|
Local
(
nbr
)
|
]
in
fill_params
rest
(
Array
.
append
res
curr
)
(
nbr
+
1
)
|
[]
->
res
,
nbr
in
fill_params
interface
[
||
]
0
fill_params
interface
[
||
]
1
in
Abstraction
(
params
,
[]
,
dummy_branches
,
nbrparams
,
true
,
List
([[]]))
|
Var
(
vname
)
->
Var
(
Local
(
0
))
(* TODO: Not supposed to be 0 *)
let
new_env
=
mk_env
~
parent
:
(
Some
env
)
~
max_size
:
env
.
max_size
~
map
:
map
nbrparams
(
env
.
global_size
+
nbrparams
+
1
)
in
Abstraction
(
params
,
[]
,
compile_branches
new_env
body
,
nbrparams
,
true
,
List
[[]])
|
Var
(
vname
)
->
(
try
let
index
=
env_find
env
vname
in
Var
(
Local
(
index
))
with
Not_found
->
raise
Not_found
)
|
Int
(
i
)
->
Const
(
Value
.
Integer
(
Intervals
.
V
.
from_int
i
))
|
String
(
s
)
->
let
s
=
Ident
.
U
.
mk
s
in
let
nil_atom
=
Atoms
.
V
.
mk_ascii
"nil"
in
String
(
Ident
.
U
.
start_index
s
,
Ident
.
U
.
end_index
s
,
s
,
Const
(
Atom
(
nil_atom
)))
Const
(
Value
.
Atom
(
nil_atom
)))
|
Pair
(
e1
,
e2
)
->
Pair
(
_parse_to_lambda
env
e1
,
_parse_to_lambda
env
e2
)
|
Match
(
e
,
branches
)
->
Match
(
_parse_to_lambda
env
e
,
dummy_
branches
)
Match
(
_parse_to_lambda
env
e
,
compile_branches
env
branches
)
|
Let
(
x
,
e1
,
e2
)
->
(* TODO: Define the "_" *)
let
map
=
Hashtbl
.
create
page_size
in
let
new_env
=
mk_env
~
parent
:
(
Some
env
)
~
max_size
:
env
.
max_size
~
map
:
map
~
locals
:
[
|
Local
(
env
.
global_size
)
|
]
1
(
env
.
global_size
+
1
)
in
Hashtbl
.
add
map
x
0
;
let
new_env
=
mk_env
~
parent
:
(
Some
env
)
~
max_size
:
env
.
max_size
~
map
:
map
1
(
env
.
global_size
+
1
)
in
Apply
(
_parse_to_lambda
new_env
(
Abstract
(
"_"
,
[
x
]
,
e2
))
,
_parse_to_lambda
env
e1
)
in
_parse_to_lambda
(
mk_env
0
0
)
expr
let
rec
print_value
v
=
match
v
with
|
Value
.
Pair
(
v1
,
v2
)
->
printf
"("
;
print_value
v1
;
printf
", "
;
print_value
v2
;
printf
")"
|
Xml
(
_
,_,_
)
->
printf
"Xml"
|
XmlNs
(
_
,_,_,_
)
->
printf
"XmlNs"
|
Record
(
_
)
->
printf
"Record"
|
Atom
(
_
)
->
printf
"Atom"
|
Integer
(
i
)
->
printf
"%d"
(
Big_int
.
int_of_big_int
i
)
|
Char
(
i
)
->
printf
"Char(%d)"
i
|
Abstraction
(
_
,
_
)
->
printf
"Abstraction()"
|
Abstract
((
name
,
_
))
->
printf
"Abstract(%s)"
name
|
String_latin1
(
i1
,
i2
,
s
,
v
)
->
printf
"String_latin1(%d, %d, %s)"
i1
i2
s
;
print_value
v
|
String_utf8
(
_
,_,
s
,_
)
->
printf
"String(%s)"
s
|
Concat
(
v1
,
v2
)
->
printf
"Concat("
;
print_value
v1
;
printf
", "
;
print_value
v2
;
printf
")"
|
Absent
->
printf
"Absent"
tests/eval/src/compile.mli
0 → 100644
View file @
04247512
val
parse_to_lambda
:
Parse
.
expr
->
Lambda
.
expr
tests/eval/src/main.ml
View file @
04247512
open
Printf
open
Parse
open
Value
let
load_file
f
=
let
ic
=
open_in
f
in
...
...
@@ -9,13 +10,31 @@ let load_file f =
close_in
ic
;
s
let
rec
print_value
v
=
match
v
with
|
Value
.
Pair
(
v1
,
v2
)
->
printf
"("
;
print_value
v1
;
printf
", "
;
print_value
v2
;
printf
")"
|
Xml
(
_
,_,_
)
->
printf
"Xml"
|
XmlNs
(
_
,_,_,_
)
->
printf
"XmlNs"
|
Record
(
_
)
->
printf
"Record"
|
Atom
(
_
)
->
printf
"Atom"
|
Integer
(
i
)
->
printf
"%d"
(
Big_int
.
int_of_big_int
i
)
|
Char
(
i
)
->
printf
"Char(%d)"
i
|
Abstraction
(
_
,
_
)
->
printf
"Abstraction()"
|
Abstract
((
name
,
_
))
->
printf
"Abstract(%s)"
name
|
String_latin1
(
i1
,
i2
,
s
,
v
)
->
printf
"String_latin1(%d, %d, %s)"
i1
i2
s
;
print_value
v
|
String_utf8
(
_
,_,
s
,_
)
->
printf
"String(%s)"
s
|
Concat
(
v1
,
v2
)
->
printf
"Concat("
;
print_value
v1
;
printf
", "
;
print_value
v2
;
printf
")"
|
Absent
->
printf
"Absent"
let
str
=
if
Array
.
length
Sys
.
argv
>
1
then
load_file
Sys
.
argv
.
(
1
)
else
(*"let z = 3 in fun firsts x y -> match x,y with
| (a,_),(b,_) -> a,b (* This (* is (* a nested *) *) comment *)
| _ -> x . z (* That doesn't make any sense *)"*)
"
\"
The cake is a lie
\"
"
in
| _ -> x . z (* That doesn't make any sense *)"*)
"
let x = 2 in x
"
in
let
expr
=
ExprParser
.
of_string
str
in
(*printf "Original: %s\nExpr: " str;
print_expr expr;
printf "\nResult: %s\n" (expr_to_string expr);*)
let
evalexpr
=
Eval
.
expr
(
Compile
.
parse_to_lambda
expr
)
100
in
Compile
.
print_value
evalexpr
;
printf
"
\n
"
print_value
evalexpr
;
printf
"
\n
"
tests/eval/src/parse.ml
View file @
04247512
...
...
@@ -8,7 +8,7 @@ type expr =
|
String
of
string
|
Pair
of
expr
*
expr
|
Match
of
expr
*
(
expr
*
string
option
*
expr
)
list
|
Let
of
string
*
expr
*
expr
;;
|
Let
of
string
*
expr
*
expr
module
ExprParser
=
struct
open
Camlp4
.
PreCast
...
...
@@ -55,9 +55,7 @@ module ExprParser = struct
END
;;
let
of_string
s
=
Gram
.
parse_string
exp_eoi
(
Loc
.
mk
"<string>"
)
s
let
os
=
of_string
end
;;
end
exception
InvalidBranches
;;
...
...
tests/eval/src/parse.mli
0 → 100644
View file @
04247512
type
expr
=
|
Apply
of
expr
*
expr
|
Abstract
of
string
*
string
list
*
expr
|
Var
of
string
|
Int
of
int
|
String
of
string
|
Pair
of
expr
*
expr
|
Match
of
expr
*
(
expr
*
string
option
*
expr
)
list
|
Let
of
string
*
expr
*
expr
module
ExprParser
:
sig
val
of_string
:
string
->
expr
end
val
print_expr
:
expr
->
unit
val
expr_to_string
:
expr
->
string
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