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
bf2fe4ef
Commit
bf2fe4ef
authored
May 14, 2014
by
Pietro Abate
Browse files
Merge branch 'eval-test' into master-merge
parents
23a63dd2
337588ee
Changes
15
Expand all
Hide whitespace changes
Inline
Side-by-side
compile/compile.ml
View file @
bf2fe4ef
...
...
@@ -141,7 +141,7 @@ and compile_abstr env a =
let
slots
=
Array
.
of_list
(
List
.
rev
slots
)
in
let
env
=
{
env
with
vars
=
fun_env
;
gamma
=
(
env
.
gamma
@
fun_name
)
;
let
env
=
{
env
with
vars
=
fun_env
;
gamma
=
IdMap
.
merge
(
fun
_
v2
->
v2
)
env
.
gamma
fun_name
;
stack_size
=
0
;
max_stack
=
ref
0
}
in
let
body
=
compile_branches
env
a
.
Typed
.
fun_body
in
let
sigma
=
`Sel
(
a
.
Typed
.
fun_fv
,
a
.
Typed
.
fun_iface
,
env
.
sigma
)
in
...
...
@@ -177,10 +177,18 @@ and compile_branches env (brs : Typed.branches) =
(* p_i / t_i -> br.Typed.br_pat / br.Typed.br_type
* p_i / t_i is used here to add elements to env.gamma *)
and
compile_branch
env
br
=
let
env
=
List
.
fold_left
enter_local
env
(
Patterns
.
fv
br
.
Typed
.
br_pat
)
in
let
m
=
Patterns
.
filter
(
Types
.
descr
(
Patterns
.
accept
br
.
Typed
.
br_pat
))
br
.
Typed
.
br_pat
in
(* We add a fresh variable "pat<nb>:x" for each pattern
TODO: Add a fresh variable for cap too. *)
let
t
,
_
,
d
=
br
.
Typed
.
br_pat
.
Patterns
.
descr
in
let
fv
=
match
d
with
|
Patterns
.
Constr
(
_
)
|
Patterns
.
Cap
(
_
)
->
Patterns
.
fv
br
.
Typed
.
br_pat
|
_
->
incr
Patterns
.
counter
;
(
Patterns
.
fv
br
.
Typed
.
br_pat
)
@
[
!
Patterns
.
counter
,
"pat"
^
(
string_of_int
!
Patterns
.
counter
)
^
":x"
]
in
let
pat
=
{
br
.
Typed
.
br_pat
with
Patterns
.
descr
=
(
t
,
fv
,
d
);
Patterns
.
fv
=
fv
}
in
let
env
=
List
.
fold_left
enter_local
env
fv
in
let
m
=
Patterns
.
filter
(
Types
.
descr
(
Patterns
.
accept
pat
))
pat
in
let
env
=
{
env
with
gamma
=
IdMap
.
union_disj
m
env
.
gamma
}
in
(
br
.
Typed
.
br_
pat
,
compile
env
br
.
Typed
.
br_body
)
(
pat
,
compile
env
br
.
Typed
.
br_body
)
let
enter_globals
env
n
=
match
env
.
cu
with
|
None
->
List
.
fold_left
enter_global_toplevel
env
n
...
...
tests/lambda/GRAMMAR
View file @
bf2fe4ef
expr = id
| integer
| `true
| `false
|
string
|
"
`true
"
|
"
`false
"
|
STRING
| abstr
| "let" LIDENT ":" type_id "=" expr "in" expr ":" type_id
| "if" expr "then" expr
| "if" expr "then" expr "else" expr
| expr "." expr
| expr "," expr
| expr "{" id "/" type_id sigma "}"
| expr "=" expr
| expr "+" expr
| expr "-" expr
| expr "*" expr
| expr "/" expr
| expr "%" expr
| expr "@" expr
| expr "[" sigmalist "]" (* type substitutions *)
| "(" expr ")"
| "[" "]" (* nil *)
| "[" listexpr "]"
| "match" expr ":" type_id "with" "|" match_value "->" expr branches
;;
sigmalist = (* empty *)
| "{" "}" "," sigmalist
| "{" UIDENT "/" type_id sigma "}" "," sigmalist
;;
sigma = (* empty *)
| ";" id "/" type_id
| ";" UIDENT "/" type_id
;;
listexpr = (* empty *)
| expr
listexpr = expr
| listexpr ";" listexpr
;;
abstr = "fun" id id ":" type_id params ":" type_id "->" expr
| "fun" "_" id ":" type_id params ":" type_id "->" expr
| "fun" type_id "|" match_value "->" expr branches
;;
match_value = id ":" type_id
| integer
|
string
|
STRING
| match_value "," match_value
| match_value "::" match_value
| "(" match_value ")"
;;
params = (* empty *)
| id ":" type_id params
;;
branches = (* empty *)
| "|" match_value "->" expr branches
;;
(* Note: The first character of an id is lower case (or '_'), the first
character of a type is upper case *)
id = [a-z_][A-Za-z0-9_]*
id = LIDENT (* [a-z_][A-Za-z0-9_]* *)
;;
type_id = [A-Z][A-Za-z0-9_]*
| "'"[A-Z][A-Za-z0-9_]*
| "'"[A-Z][A-Za-z0-9_]* "{" id "/" type_id sigma "}"
(* One must precise a set of type substitutions on a type variable, at least a
empty one: α = 'A{} *)
type_id = UIDENT
| "'" UIDENT "[" sigmalist "]"
| "[" complex_type_id "]"
| "(" complex_type_id ")"
;;
complex_type_id = [A-Z][A-Za-z0-9_]*
| "'"[A-Z][A-Za-z0-9_]*
| "'"[A-Z][A-Za-z0-9_]* "{" id "/" type_id sigma "}"
complex_type_id = UIDENT (* [A-Z][A-Za-z0-9_]* *)
| "'" UIDENT "[" sigmalist "]"
| complex_type_id "*" complex_type_id
| complex_type_id "|" complex_type_id
| complex_type_id "&" complex_type_id
| "!" complex_type_id
| complex_type_id -> complex_type_id
| complex_type_id
"
->
"
complex_type_id
| "[" complex_type_id "]"
| "(" complex_type_id ")"
;;
integer = [0-9]+
integer =
INTEGER (*
[0-9]+
*)
tests/lambda/Makefile
View file @
bf2fe4ef
...
...
@@ -25,7 +25,7 @@ RM ?= rm -f
OUT
?=
main.native
OUTDEBUG
?=
main.byte
.PHONY
:
clean
check test
_import
.PHONY
:
clean _import
tests
all
:
_import
$(COMPILER)
-use-ocamlfind
$(OUT)
...
...
@@ -33,6 +33,9 @@ all: _import
debug
:
_import
$(COMPILER)
-use-ocamlfind
-tag
debug
$(OUTDEBUG)
tests
:
make
-C
tests
_import
:
@
echo
-n
"Copying external files..."
@
test
-d
$(EXTDIR)
||
mkdir
$(EXTDIR)
...
...
@@ -40,5 +43,6 @@ _import:
@
echo
"done"
clean
:
make
-C
tests clean
$(COMPILER)
-clean
test
$(EXTDIR)
=
"src"
||
test
$(EXTDIR)
=
"."
||
$(RM)
-r
$(EXTDIR)
tests/lambda/src/compute.ml
View file @
bf2fe4ef
...
...
@@ -45,15 +45,24 @@ let rec _to_typed env l expr =
let
_
,
_
,
e2
=
_to_typed
env
l
e2
in
let
t
=
Types
.
times
(
Types
.
cons
e1
.
exp_typ
)
(
Types
.
cons
e2
.
exp_typ
)
in
env
,
l
,
{
exp_loc
=
loc
;
exp_typ
=
t
;
exp_descr
=
Pair
(
e1
,
e2
)
}
|
Op
(
_
,
op
,
e1
,
e2
)
->
let
_
,
_
,
e1
=
_to_typed
env
l
e1
in
let
_
,
_
,
e2
=
_to_typed
env
l
e2
in
env
,
l
,
{
exp_loc
=
loc
;
exp_typ
=
type_of_string
"Int"
;
exp_descr
=
Op
(
op
,
0
,
[
e1
;
e2
])
}
|
Var
(
origloc
,
vname
)
->
let
line
=
Loc
.
start_line
origloc
in
let
cbegin
=
Loc
.
start_off
origloc
-
Loc
.
start_bol
origloc
in
let
cend
=
Loc
.
stop_off
origloc
-
Loc
.
start_bol
origloc
in
if
vname
=
"`nil"
then
let
nil_atom
=
Atoms
.
V
.
mk_ascii
"nil"
in
env
,
l
,
{
exp_loc
=
loc
;
exp_typ
=
(
Types
.
atom
(
Atoms
.
atom
nil_atom
));
exp_descr
=
(
Cst
(
Types
.
Atom
nil_atom
))
}
else
if
vname
=
"_"
then
(
Printf
.
eprintf
"File %s, line %d, characters %d-%d:
\n
Error: Invalid reference to special variable %s
\n
"
(
Loc
.
file_name
origloc
)
line
cbegin
cend
vname
;
raise
Error
)
else
let
line
=
Loc
.
start_line
origloc
in
let
cbegin
=
Loc
.
start_off
origloc
-
Loc
.
start_bol
origloc
in
let
cend
=
Loc
.
stop_off
origloc
-
Loc
.
start_bol
origloc
in
let
index
,
vtype
=
try
Locals
.
find
vname
l
with
Not_found
->
Printf
.
eprintf
...
...
@@ -90,27 +99,31 @@ let rec _to_typed env l expr =
raise
Error
and
make_sigma
s
=
let
rec
aux
acc
=
function
let
rec
aux
2
acc
=
function
|
(
name
,
ptype
)
::
rest
->
aux
([
`Var
(
Var
.
make_id
name
)
,
type_of_ptype
ptype
]
::
acc
)
rest
|
[]
->
acc
in
aux2
((
Var
.
mk
name
,
type_of_ptype
ptype
)
::
acc
)
rest
|
[]
->
acc
in
let
rec
aux
acc
=
function
|
l
::
rest
->
aux
(
acc
@
[
aux2
[]
l
])
rest
|
[]
->
acc
in
aux
[]
s
and
type_of_sigma
x
s
=
let
rec
aux
x
acc
=
function
let
rec
aux
2
x
acc
=
function
|
[]
->
acc
|
(
id
,
t2
)
::
rest
when
id
=
x
->
aux
x
(
Types
.
cup
acc
(
type_of_ptype
t2
))
rest
|
_
::
rest
->
aux
x
acc
rest
in
aux2
x
(
Types
.
cap
acc
(
type_of_ptype
t2
))
rest
|
_
::
rest
->
aux2
x
acc
rest
in
let
rec
aux
x
acc
=
function
|
[]
->
acc
|
l
::
rest
->
aux
x
(
Types
.
cup
acc
(
aux2
x
Types
.
any
l
))
rest
in
aux
x
Types
.
empty
s
and
type_of_ptype
=
let
open
Types
in
function
|
Type
(
t
)
->
type_of_string
t
|
PType
(
t
,
s
)
->
if
s
=
[]
then
var
(
`Var
(
Var
.
make_id
t
))
else
type_of_sigma
t
s
if
s
=
[
[]
]
then
var
(
`Var
(
Var
.
make_id
t
))
else
type_of_sigma
t
s
|
TPair
(
t1
,
t2
)
->
times
(
cons
(
type_of_ptype
t1
))
(
cons
(
type_of_ptype
t2
))
|
TUnion
(
t1
,
t2
)
->
cup
(
type_of_ptype
t1
)
(
type_of_ptype
t2
)
|
TInter
(
t1
,
t2
)
->
cap
(
type_of_ptype
t1
)
(
type_of_ptype
t2
)
...
...
@@ -212,14 +225,22 @@ and parse_match_value env l list toptype = function
Patterns
.
Times
(
make_patterns
t1
list1
d1
,
make_patterns
t2
list2
d2
)
,
(
list1
@
list2
)
,
l
,
b1
&&
b2
;
|
MVar
(
_
,
mname
,
mtype
)
->
let
lsize
=
Locals
.
cardinal
l
in
let
l
=
Locals
.
add
mname
(
lsize
,
type_of_ptype
mtype
)
l
in
let
list
=
list
@
[
lsize
,
mname
]
in
let
d1
=
Types
.
any
,
list
,
Patterns
.
Capture
(
lsize
,
mname
)
in
let
t2
=
type_of_ptype
mtype
in
let
d2
=
t2
,
[]
,
Patterns
.
Constr
(
t2
)
in
let
is_subtype
=
Types
.
subtype
t2
(
type_of_ptype
toptype
)
in
(
t2
,
Patterns
.
Cap
(
d1
,
d2
)
,
list
,
l
,
is_subtype
)
if
mname
=
"`nil"
then
let
nil_atom
=
Atoms
.
V
.
mk_ascii
"nil"
in
let
t
=
Types
.
atom
(
Atoms
.
atom
nil_atom
)
in
(
t
,
Patterns
.
Constr
(
t
)
,
list
,
l
,
true
)
else
if
mname
=
"_"
then
let
t
=
type_of_ptype
mtype
in
(
t
,
Patterns
.
Constr
(
t
)
,
list
,
l
,
true
)
else
let
lsize
=
Locals
.
cardinal
l
in
let
l
=
Locals
.
add
mname
(
lsize
,
type_of_ptype
mtype
)
l
in
let
list
=
list
@
[
lsize
,
mname
]
in
let
d1
=
Types
.
any
,
list
,
Patterns
.
Capture
(
lsize
,
mname
)
in
let
t2
=
type_of_ptype
mtype
in
let
d2
=
t2
,
[]
,
Patterns
.
Constr
(
t2
)
in
let
is_subtype
=
Types
.
subtype
t2
(
type_of_ptype
toptype
)
in
(
t2
,
Patterns
.
Cap
(
d1
,
d2
)
,
list
,
l
,
is_subtype
)
|
MInt
(
_
,
i
)
->
let
t
=
Types
.
constant
(
Types
.
Integer
(
Big_int
.
big_int_of_int
i
))
in
let
is_subtype
=
Types
.
subtype
(
type_of_string
"Int"
)
...
...
@@ -231,7 +252,55 @@ and parse_match_value env l list toptype = function
let
is_subtype
=
Types
.
subtype
(
type_of_string
"String"
)
(
type_of_ptype
toptype
)
in
(
t
,
Patterns
.
Constr
(
t
)
,
list
,
l
,
is_subtype
)
|
MBool
(
origloc
,
b
)
->
let
t
=
match
b
with
|
"true"
->
Types
.
atom
(
Atoms
.
atom
(
Atoms
.
V
.
mk_ascii
"true"
))
|
"false"
->
Types
.
atom
(
Atoms
.
atom
(
Atoms
.
V
.
mk_ascii
"false"
))
|
_
->
let
line
=
Loc
.
start_line
origloc
in
let
cbegin
=
Loc
.
start_off
origloc
-
Loc
.
start_bol
origloc
in
let
cend
=
Loc
.
stop_off
origloc
-
Loc
.
start_bol
origloc
in
Printf
.
eprintf
"File %s, line %d, characters %d-%d:
\n
Error: Unknown special term %s
\n
"
(
Loc
.
file_name
origloc
)
line
cbegin
cend
b
;
raise
Error
in
let
is_subtype
=
Types
.
subtype
t
(
type_of_ptype
toptype
)
in
(
t
,
Patterns
.
Constr
(
t
)
,
list
,
l
,
is_subtype
)
let
arith_op
f
=
function
|
Value
.
Integer
(
x
)
::
Value
.
Integer
(
y
)
::
[]
->
Value
.
Integer
(
Big_int
.
big_int_of_int
(
f
(
Big_int
.
int_of_big_int
x
)
(
Big_int
.
int_of_big_int
y
)))
|
_
->
raise
Error
let
equal
=
function
|
Value
.
Integer
(
x
)
::
Value
.
Integer
(
y
)
::
[]
->
let
b
=
if
Big_int
.
int_of_big_int
x
=
Big_int
.
int_of_big_int
y
then
"true"
else
"false"
in
Value
.
Atom
(
Atoms
.
V
.
mk_ascii
b
)
|
_
->
raise
Error
let
concat
=
let
rec
add_to_tail
y
=
function
|
Value
.
Pair
(
x
,
nil
,
s
)
->
if
nil
=
Value
.
Atom
(
Atoms
.
V
.
mk_ascii
"nil"
)
then
Value
.
Pair
(
x
,
y
,
s
)
else
Value
.
Pair
(
x
,
add_to_tail
y
nil
,
s
)
|
_
->
raise
Error
in
function
|
(
Value
.
Pair
(
_
,
_
,
_
)
as
x
)
::
(
Value
.
Pair
(
_
)
as
y
)
::
[]
->
add_to_tail
y
x
|
x
::
y
::
[]
->
if
x
=
Value
.
Atom
(
Atoms
.
V
.
mk_ascii
"nil"
)
then
y
else
if
y
=
Value
.
Atom
(
Atoms
.
V
.
mk_ascii
"nil"
)
then
x
else
raise
Error
|
_
->
raise
Error
let
to_typed
expr
=
Eval
.
register_op
"+"
(
arith_op
(
+
));
Eval
.
register_op
"-"
(
arith_op
(
-
));
Eval
.
register_op
"*"
(
arith_op
(
*
));
Eval
.
register_op
"/"
(
arith_op
(
/
));
Eval
.
register_op
"%"
(
arith_op
(
mod
));
Eval
.
register_op
"="
equal
;
Eval
.
register_op
"@"
concat
;
let
env
,
_
,
expr
=
_to_typed
Compile
.
empty_toplevel
Locals
.
empty
expr
in
env
,
expr
tests/lambda/src/main.ml
View file @
bf2fe4ef
This diff is collapsed.
Click to expand it.
tests/lambda/src/parse.ml
View file @
bf2fe4ef
...
...
@@ -2,11 +2,12 @@ open Printf
open
Camlp4
.
PreCast
type
expr
=
|
Subst
of
Loc
.
t
*
expr
*
(
string
*
ptype
)
list
|
Subst
of
Loc
.
t
*
expr
*
(
string
*
ptype
)
list
list
|
Apply
of
Loc
.
t
*
expr
*
expr
|
Abstr
of
Loc
.
t
*
fun_name
*
ptype
*
fv
*
branches
|
Match
of
Loc
.
t
*
expr
*
ptype
*
branches
|
Pair
of
Loc
.
t
*
expr
*
expr
|
Op
of
Loc
.
t
*
string
*
expr
*
expr
|
Var
of
Loc
.
t
*
string
|
Int
of
Loc
.
t
*
int
|
String
of
Loc
.
t
*
string
...
...
@@ -19,9 +20,10 @@ and match_value =
|
MVar
of
Loc
.
t
*
string
*
ptype
|
MInt
of
Loc
.
t
*
int
|
MString
of
Loc
.
t
*
string
|
MBool
of
Loc
.
t
*
string
and
ptype
=
|
Type
of
string
|
PType
of
string
*
(
string
*
ptype
)
list
|
PType
of
string
*
(
string
*
ptype
)
list
list
|
TPair
of
ptype
*
ptype
|
TUnion
of
ptype
*
ptype
|
TInter
of
ptype
*
ptype
...
...
@@ -52,31 +54,55 @@ module ExprParser = struct
|
(
loc
,
pname
,
ptype
)
::
rest
->
let
t
=
TArrow
(
ptype
,
t
)
in
let
newfv
=
match
fv
with
|
_
::
rest
->
rest
|
[]
->
assert
false
in
aux
(
Abstr
(
_loc
,
x
,
t
,
fv
,
[
_loc
,
MVar
(
loc
,
pname
,
ptype
)
,
acc
]))
aux
(
Abstr
(
_loc
,
"_"
,
t
,
fv
,
[
_loc
,
MVar
(
loc
,
pname
,
ptype
)
,
acc
]))
t
newfv
rest
|
[]
->
acc
in
aux
e
t
(
make_fv
[]
1
p
)
(
List
.
rev
p
)
aux
e
t
(
make_fv
[
0
,
x
]
1
p
)
(
List
.
rev
p
)
|
"fun"
;
t
=
type_id
;
b
=
LIST1
branch
->
Abstr
(
_loc
,
"_"
,
t
,
[]
,
b
)
|
"let"
;
x
=
LIDENT
;
":"
;
t
=
type_id
;
"="
;
v
=
SELF
;
"in"
;
e
=
SELF
;
":"
;
te
=
type_id
->
Match
(
_loc
,
v
,
t
,
[
_loc
,
MVar
(
_loc
,
x
,
t
)
,
e
])
|
"if"
;
e1
=
SELF
;
"then"
;
e2
=
SELF
->
let
b
=
[(
_loc
,
MBool
(
_loc
,
"true"
)
,
e2
);
(
_loc
,
MBool
(
_loc
,
"false"
)
,
Var
(
_loc
,
"`nil"
))]
in
Match
(
_loc
,
e1
,
Type
(
"Bool"
)
,
b
)
|
"if"
;
e1
=
SELF
;
"then"
;
e2
=
SELF
;
"else"
;
e3
=
SELF
->
let
b
=
[(
_loc
,
MBool
(
_loc
,
"true"
)
,
e2
);
(
_loc
,
MBool
(
_loc
,
"false"
)
,
e3
)]
in
Match
(
_loc
,
e1
,
Type
(
"Bool"
)
,
b
)
|
"match"
;
e
=
SELF
;
":"
;
t
=
type_id
;
"with"
;
b
=
LIST1
branch
->
Match
(
_loc
,
e
,
t
,
b
)
]
|
"pair"
LEFTA
[
e1
=
SELF
;
","
;
e2
=
SELF
->
Pair
(
_loc
,
e1
,
e2
)
|
e1
=
SELF
;
"."
;
e2
=
SELF
->
Apply
(
_loc
,
e1
,
e2
)
]
|
"list"
LEFTA
[
"["
;
le
=
listexpr
;
"]"
->
le
]
|
"egal"
LEFTA
[
e1
=
SELF
;
"="
;
e2
=
SELF
->
Op
(
_loc
,
"="
,
e1
,
e2
)
]
|
"add"
LEFTA
[
e1
=
SELF
;
"+"
;
e2
=
SELF
->
Op
(
_loc
,
"+"
,
e1
,
e2
)
|
e1
=
SELF
;
"-"
;
e2
=
SELF
->
Op
(
_loc
,
"-"
,
e1
,
e2
)
]
|
"mult"
LEFTA
[
e1
=
SELF
;
"*"
;
e2
=
SELF
->
Op
(
_loc
,
"*"
,
e1
,
e2
)
|
e1
=
SELF
;
"/"
;
e2
=
SELF
->
Op
(
_loc
,
"/"
,
e1
,
e2
)
|
e1
=
SELF
;
"%"
;
e2
=
SELF
->
Op
(
_loc
,
"%"
,
e1
,
e2
)
]
|
"concat"
LEFTA
[
e1
=
SELF
;
"@"
;
e2
=
SELF
->
Op
(
_loc
,
"@"
,
e1
,
e2
)
]
|
"pair"
LEFTA
[
e1
=
SELF
;
","
;
e2
=
SELF
->
Pair
(
_loc
,
e1
,
e2
)
]
|
"apply"
[
e1
=
SELF
;
"."
;
e2
=
SELF
->
Apply
(
_loc
,
e1
,
e2
)
]
|
"list"
LEFTA
[
"["
;
le
=
LIST0
SELF
SEP
";"
;
"]"
->
let
rec
make_seq
res
=
function
|
e
::
rest
->
make_seq
(
Pair
(
_loc
,
e
,
res
))
rest
|
[]
->
res
in
make_seq
(
Var
(
_loc
,
"`nil"
))
(
List
.
rev
le
)
]
|
"paren"
[
"("
;
e
=
SELF
;
")"
->
e
]
|
"var"
[
x
=
LIDENT
->
Var
(
_loc
,
x
)
]
|
"int"
[
x
=
INT
->
Int
(
_loc
,
int_of_string
x
)
]
|
"string"
[
x
=
STRING
->
String
(
_loc
,
x
)
]
|
"bool"
[
"`"
;
x
=
LIDENT
->
Bool
(
_loc
,
x
)
]
|
"subst"
NONA
[
e
=
SELF
;
"
{
"
;
s
=
LIST
1
sigma
SEP
"
;
"
;
"
}
"
->
Subst
(
_loc
,
e
,
s
)
]
[
e
=
SELF
;
"
[
"
;
s
=
LIST
0
sigma
SEP
"
,
"
;
"
]
"
->
Subst
(
_loc
,
e
,
s
)
]
];
sigma
:
[[
x
=
UIDENT
;
"
/
"
;
t
=
type_id
->
x
,
t
]];
sigma
:
[[
"{"
;
l
=
LIST0
subst
SEP
"
;
"
;
"}"
->
l
]];
listexpr
:
[
"rec"
RIGHTA
[
l1
=
SELF
;
";"
;
l2
=
SELF
->
Pair
(
_loc
,
l1
,
l2
)
]
|
[
e
=
expression
->
e
]];
subst
:
[[
x
=
UIDENT
;
"/"
;
t
=
type_id
->
x
,
t
]];
param
:
[[
p
=
LIDENT
;
":"
;
t
=
type_id
->
_loc
,
p
,
t
]];
...
...
@@ -92,18 +118,20 @@ module ExprParser = struct
|
"var"
[
x
=
LIDENT
;
":"
;
t
=
type_id
->
MVar
(
_loc
,
x
,
t
)
]
|
"int"
[
x
=
INT
->
MInt
(
_loc
,
int_of_string
x
)
]
|
"string"
[
x
=
STRING
->
MString
(
_loc
,
x
)
]
|
"bool"
[
"`"
;
x
=
LIDENT
->
MBool
(
_loc
,
x
)
]
|
"empty"
[
"["
;
"]"
->
MVar
(
_loc
,
"`nil"
,
Type
(
"Any"
))
]
];
type_id
:
[
"atom_type"
[
t
=
UIDENT
->
Type
(
t
)
]
|
[
"'"
;
t1
=
UIDENT
;
"
{
"
;
s
=
LIST0
sigma
SEP
"
;
"
;
"
}
"
->
PType
(
t1
,
s
)
]
|
[
"'"
;
t1
=
UIDENT
;
"
[
"
;
s
=
LIST0
sigma
SEP
"
,
"
;
"
]
"
->
PType
(
t1
,
s
)
]
|
[
"("
;
t
=
complex_type_id
;
")"
->
t
]
|
[
"["
;
t
=
complex_type_id
;
"]"
->
TSeq
(
t
)
]
];
complex_type_id
:
[
"complex_type"
LEFTA
[
t
=
UIDENT
->
Type
(
t
)
|
"("
;
t
=
SELF
;
")"
->
t
]
|
[
"'"
;
t1
=
UIDENT
;
"
{
"
;
s
=
LIST0
sigma
SEP
"
;
"
;
"
}
"
->
PType
(
t1
,
s
)
]
|
[
"'"
;
t1
=
UIDENT
;
"
[
"
;
s
=
LIST0
sigma
SEP
"
,
"
;
"
]
"
->
PType
(
t1
,
s
)
]
|
[
t1
=
SELF
;
"*"
;
t2
=
SELF
->
TPair
(
t1
,
t2
)
|
t1
=
SELF
;
"->"
;
t2
=
SELF
->
TArrow
(
t1
,
t2
)
]
|
[
t1
=
SELF
;
"|"
;
t2
=
SELF
->
TUnion
(
t1
,
t2
)
|
t1
=
SELF
;
"&"
;
t2
=
SELF
->
TInter
(
t1
,
t2
)
]
|
[
"!"
;
t
=
SELF
->
TNot
(
t
)
]
...
...
@@ -122,6 +150,7 @@ let get_loc expr = match expr with
|
Abstr
(
loc
,
_
,
_
,
_
,
_
)
->
loc
|
Match
(
loc
,
_
,
_
,
_
)
->
loc
|
Pair
(
loc
,
_
,
_
)
->
loc
|
Op
(
loc
,
_
,
_
,
_
)
->
loc
|
Var
(
loc
,
_
)
->
loc
|
Int
(
loc
,
_
)
->
loc
|
String
(
loc
,
_
)
->
loc
...
...
tests/lambda/src/parse.mli
View file @
bf2fe4ef
open
Camlp4
.
PreCast
type
expr
=
|
Subst
of
Loc
.
t
*
expr
*
(
string
*
ptype
)
list
|
Subst
of
Loc
.
t
*
expr
*
(
string
*
ptype
)
list
list
|
Apply
of
Loc
.
t
*
expr
*
expr
|
Abstr
of
Loc
.
t
*
fun_name
*
ptype
*
fv
*
branches
|
Match
of
Loc
.
t
*
expr
*
ptype
*
branches
|
Pair
of
Loc
.
t
*
expr
*
expr
|
Op
of
Loc
.
t
*
string
*
expr
*
expr
|
Var
of
Loc
.
t
*
string
|
Int
of
Loc
.
t
*
int
|
String
of
Loc
.
t
*
string
...
...
@@ -18,9 +19,10 @@ and match_value =
|
MVar
of
Loc
.
t
*
string
*
ptype
|
MInt
of
Loc
.
t
*
int
|
MString
of
Loc
.
t
*
string
|
MBool
of
Loc
.
t
*
string
and
ptype
=
|
Type
of
string
|
PType
of
string
*
(
string
*
ptype
)
list
|
PType
of
string
*
(
string
*
ptype
)
list
list
|
TPair
of
ptype
*
ptype
|
TUnion
of
ptype
*
ptype
|
TInter
of
ptype
*
ptype
...
...
tests/lambda/src/printer.ml
View file @
bf2fe4ef
...
...
@@ -62,6 +62,7 @@ and pp_typed_aux ppf e =
Format
.
fprintf
ppf
"Match(%a,%a)"
pp_typed
e
pp_branches
b
|
Typed
.
Subst
(
e
,
s
)
->
Format
.
fprintf
ppf
"Subst(%a,[%a])"
pp_typed
e
pp_typedsigma
s
|
Typed
.
Op
(
s
,
i
,
l
)
->
Format
.
fprintf
ppf
"(%s, %d, "
s
i
;
(
print_lst
pp_typed
ppf
l
);
Format
.
fprintf
ppf
")"
|
_
->
assert
false
and
pp_abst
ppf
abstr
=
...
...
tests/lambda/tests/Makefile
0 → 100644
View file @
bf2fe4ef
COMPILER
?=
ocamlbuild
SRCDIR
?=
src
RM
?=
rm
-f
OUT
?=
gen_test.native
OUTDEBUG
?=
gen_test.byte
.PHONY
:
clean
all
:
$(COMPILER)
-use-ocamlfind
$(OUT)
debug
:
$(COMPILER)
-use-ocamlfind
-tag
debug
$(OUTDEBUG)
clean
:
$(COMPILER)
-clean
tests/lambda/tests/_tags
0 → 100644
View file @
bf2fe4ef
<src>: include
<src/parse*>: pp(camlp4orf.opt), package(camlp4.lib)
<src/compute*>: pp(camlp4orf.opt), package(camlp4.lib)
<src/gen_test*>: pp(camlp4orf.opt), package(camlp4.lib)
tests/lambda/tests/src/compute.ml
0 → 100644
View file @
bf2fe4ef
open
Parse
open
Camlp4
.
PreCast
module
Rules
=
Map
.
Make
(
String
)
let
rules
=
ref
Rules
.
empty
let
arules
=
ref
[
||
]
exception
Error
let
rec
init
l
=
match
l
with
|
Rule
(
_
,
name
,
tokens
)
::
rest
->
rules
:=
Rules
.
add
name
tokens
!
rules
;
arules
:=
Array
.
append
!
arules
[
|
name
|
];
init
rest
|
[]
->
()
let
rec
is_terminal
state
=
match
state
with
|
RefRule
(
_
)
::
rest
->
false
|
_
::
rest
->
is_terminal
rest
|
[]
->
true
let
rec
get_state
nb
=
function
(* Fix this: If no terminal state in rule, here we choose the last one *)
|
state
::
[]
->
if
nb
<=
0
then
state
else
assert
false
|
state
::
rest
->
if
(
nb
<
0
&&
not
(
is_terminal
state
))
||
nb
>
0
then
get_state
(
nb
-
1
)
rest
else
state
|
_
->
assert
false
let
rec
g_ident
nb
res
=
if
nb
=
0
||
(
res
!=
""
&&
Random
.
int
2
=
0
)
then
res
else
let
rand
=
Random
.
int
63
in
let
res
=
res
^
(
if
rand
<
26
then
String
.
make
1
(
char_of_int
(
int_of_char
'
a'
+
rand
))
else
if
rand
<
52
then
String
.
make
1
(
char_of_int
(
int_of_char
'
A'
+
rand
-
26
))
else
if
rand
<
62
then
String
.
make
1
(
char_of_int
(
int_of_char
'
0
'
+
rand
-
52
))
else
"_"
)
in
g_ident
(
nb
-
1
)
res
let
g_lident
nb
res
=
if
nb
=
0
then
res
else
let
rand
=
Random
.
int
27
in
let
res
=
res
^
" "
^
(
if
rand
=
26
then
"_"
else
String
.
make
1
(
char_of_int
(
int_of_char
'
a'
+
rand
)))
in
g_ident
(
nb
-
1
)
res
let
g_uident
nb
res
=
if
nb
=
0
then
res
else
let
rand
=
Random
.
int
26
in
let
res
=
res
^
(
String
.
make
1
(
char_of_int
(
int_of_char
'
A'
+
rand
)))
in
g_ident
(
nb
-
1
)
res
let
rec
g_token
n
=
function
|
RefRule
(
loc
,
name
)
->
let
states
=
try
Rules
.
find
name
!
rules
with
Not_found
->
let
l
=
Loc
.
start_line
loc
in
let
cbegin
=
Loc
.
start_off
loc
-
Loc
.
start_bol
loc
in
let
cend
=
Loc
.
stop_off
loc
-
Loc
.
start_bol
loc
in
Printf
.
eprintf
"File %s, line %d, characters %d-%d:Unknown rule %s
\n
"
(
Loc
.
file_name
loc
)
l
cbegin
cend
name
;
raise
Error
in
g_states
""
(
max
(
n
-
1
)
0
)
states
|
String
(
_
,
s
)
->
" "
^
s
^
" "
|
Special
(
loc
,
spe
)
->
match
spe
with
|
"LIDENT"
->
g_lident
3
""
|
"UIDENT"
->
g_uident
3
""
|
"STRING"
->
"
\"
"
^
g_ident
3
""
^
"
\"
"
|
"INTEGER"
->
string_of_int
(
Random
.
int
1000
)
|
_
->
let
l
=
Loc
.
start_line
loc
in
let
cbegin
=
Loc
.
start_off
loc
-
Loc
.
start_bol
loc
in
let
cend
=
Loc
.
stop_off
loc
-
Loc
.
start_bol
loc
in
Printf
.
eprintf
"File %s, line %d, characters %d-%d:Unknown special keyword %s
\n
"
(
Loc
.
file_name
loc
)
l
cbegin
cend
spe
;
raise
Error
and
g_tokens
res
n
=
function
|
token
::
rest
->
g_tokens
(
res
^
(
g_token
n
token
))
n
rest
|
[]
->
res
and
g_states
res
n
states
=
let
max_rand
=
List
.
length
states
in
let
rand
=
Random
.
int
max_rand
in