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
9386048d
Commit
9386048d
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2003-10-01 22:59:28 by cvscast] Empty log message
Original author: cvscast Date: 2003-10-01 22:59:29+00:00
parent
bff1a3d7
Changes
14
Hide whitespace changes
Inline
Side-by-side
Makefile.distrib
View file @
9386048d
...
...
@@ -95,6 +95,7 @@ OBJECTS = \
compile/lambda.cmo
\
\
runtime/load_xml.cmo runtime/run_dispatch.cmo
\
runtime/explain.cmo
\
runtime/print_xml.cmo runtime/eval.cmo
\
compile/compile.cmo
\
compile/operators.cmo
\
...
...
compile/lambda.ml
View file @
9386048d
...
...
@@ -6,7 +6,6 @@ type var_loc =
|
Global
of
int
|
Dummy
type
expr
=
|
Var
of
var_loc
|
Apply
of
bool
*
expr
*
expr
...
...
@@ -22,10 +21,10 @@ type expr =
|
Map
of
expr
*
branches
|
Transform
of
expr
*
branches
|
Xtrans
of
expr
*
branches
|
Try
of
expr
*
branches
|
Validate
of
expr
*
string
*
string
|
RemoveField
of
expr
*
label
|
Dot
of
expr
*
label
|
Try
of
expr
*
branches
|
UnaryOp
of
int
*
expr
|
BinaryOp
of
int
*
expr
*
expr
|
Ref
of
expr
*
Types
.
Node
.
t
...
...
@@ -43,3 +42,209 @@ type let_decl = {
let_pat
:
Patterns
.
node
;
let_expr
:
expr
;
}
let
nbits
=
5
module
Put
=
struct
let
unary_op
=
ref
(
fun
_
_
->
assert
false
;
()
)
let
binary_op
=
ref
(
fun
_
_
->
assert
false
;
()
)
open
Serialize
.
Put
let
var_loc
s
=
function
|
Stack
i
->
bits
2
s
0
;
int
s
i
|
Global
i
->
bits
2
s
1
;
int
s
i
|
Env
i
->
bits
2
s
2
;
int
s
i
|
Dummy
->
bits
2
s
3
let
rec
expr
s
=
function
|
Var
v
->
bits
nbits
s
0
;
var_loc
s
v
|
Apply
(
tail
,
e1
,
e2
)
->
bits
nbits
s
1
;
bool
s
tail
;
expr
s
e1
;
expr
s
e2
|
Abstraction
(
slots
,
iface
,
brs
)
->
bits
nbits
s
2
;
array
var_loc
s
slots
;
list
(
pair
Types
.
serialize
Types
.
serialize
)
s
iface
;
branches
s
brs
|
Const
c
->
bits
nbits
s
3
;
Types
.
Const
.
serialize
s
c
|
Pair
(
e1
,
e2
)
->
bits
nbits
s
4
;
expr
s
e1
;
expr
s
e2
|
Xml
(
e1
,
e2
,
e3
)
->
bits
nbits
s
5
;
expr
s
e1
;
expr
s
e2
;
expr
s
e3
|
Record
r
->
bits
nbits
s
6
;
LabelMap
.
serialize
expr
s
r
|
String
(
i
,
j
,
st
,
q
)
->
bits
nbits
s
7
;
U
.
serialize_sub
s
st
i
j
;
expr
s
q
|
Match
(
e
,
brs
)
->
bits
nbits
s
8
;
expr
s
e
;
branches
s
brs
|
Map
(
e
,
brs
)
->
bits
nbits
s
9
;
expr
s
e
;
branches
s
brs
|
Transform
(
e
,
brs
)
->
bits
nbits
s
10
;
expr
s
e
;
branches
s
brs
|
Xtrans
(
e
,
brs
)
->
bits
nbits
s
11
;
expr
s
e
;
branches
s
brs
|
Try
(
e
,
brs
)
->
bits
nbits
s
12
;
expr
s
e
;
branches
s
brs
|
Validate
(
e
,
sch
,
t
)
->
assert
false
(* Need to store a pointer to the schema ... *)
|
RemoveField
(
e
,
l
)
->
bits
nbits
s
14
;
expr
s
e
;
LabelPool
.
serialize
s
l
|
Dot
(
e
,
l
)
->
bits
nbits
s
15
;
expr
s
e
;
LabelPool
.
serialize
s
l
|
UnaryOp
(
op
,
e
)
->
bits
nbits
s
16
;
!
unary_op
s
op
;
expr
s
e
|
BinaryOp
(
op
,
e1
,
e2
)
->
bits
nbits
s
17
;
!
binary_op
s
op
;
expr
s
e1
;
expr
s
e2
|
Ref
(
e
,
t
)
->
bits
nbits
s
18
;
expr
s
e
;
Types
.
Node
.
serialize
s
t
and
branches
s
brs
=
list
(
pair
Patterns
.
Node
.
serialize
expr
)
s
brs
.
brs
;
bool
s
brs
.
brs_tail
;
Types
.
serialize
s
brs
.
brs_input
;
bool
s
brs
.
brs_accept_chars
end
module
Get
=
struct
let
unary_op
=
ref
(
fun
_
->
assert
false
)
let
binary_op
=
ref
(
fun
_
->
assert
false
)
open
Serialize
.
Get
let
var_loc
s
=
match
bits
2
s
with
|
0
->
Stack
(
int
s
)
|
1
->
Global
(
int
s
)
|
2
->
Env
(
int
s
)
|
3
->
Dummy
|
_
->
assert
false
let
rec
expr
s
=
match
bits
nbits
s
with
|
0
->
Var
(
var_loc
s
)
|
1
->
let
recurs
=
bool
s
in
let
e1
=
expr
s
in
let
e2
=
expr
s
in
Apply
(
recurs
,
e1
,
e2
)
|
2
->
let
slots
=
array
var_loc
s
in
let
iface
=
list
(
pair
Types
.
deserialize
Types
.
deserialize
)
s
in
let
brs
=
branches
s
in
Abstraction
(
slots
,
iface
,
brs
)
|
3
->
Const
(
Types
.
Const
.
deserialize
s
)
|
4
->
let
e1
=
expr
s
in
let
e2
=
expr
s
in
Pair
(
e1
,
e2
)
|
5
->
let
e1
=
expr
s
in
let
e2
=
expr
s
in
let
e3
=
expr
s
in
Xml
(
e1
,
e2
,
e3
)
|
6
->
Record
(
LabelMap
.
deserialize
expr
s
)
|
7
->
let
st
=
U
.
deserialize
s
in
let
e
=
expr
s
in
String
(
U
.
start_index
st
,
U
.
end_index
st
,
st
,
e
)
|
8
->
let
e
=
expr
s
in
let
brs
=
branches
s
in
Match
(
e
,
brs
)
|
9
->
let
e
=
expr
s
in
let
brs
=
branches
s
in
Map
(
e
,
brs
)
|
10
->
let
e
=
expr
s
in
let
brs
=
branches
s
in
Transform
(
e
,
brs
)
|
11
->
let
e
=
expr
s
in
let
brs
=
branches
s
in
Xtrans
(
e
,
brs
)
|
12
->
let
e
=
expr
s
in
let
brs
=
branches
s
in
Try
(
e
,
brs
)
|
13
->
assert
false
|
14
->
let
e
=
expr
s
in
let
l
=
LabelPool
.
deserialize
s
in
RemoveField
(
e
,
l
)
|
15
->
let
e
=
expr
s
in
let
l
=
LabelPool
.
deserialize
s
in
Dot
(
e
,
l
)
|
16
->
let
op
=
!
unary_op
s
in
let
e
=
expr
s
in
UnaryOp
(
op
,
e
)
|
17
->
let
op
=
!
binary_op
s
in
let
e1
=
expr
s
in
let
e2
=
expr
s
in
BinaryOp
(
op
,
e1
,
e2
)
|
18
->
let
e
=
expr
s
in
let
t
=
Types
.
Node
.
deserialize
s
in
Ref
(
e
,
t
)
|
_
->
assert
false
and
branches
s
=
let
brs
=
list
(
pair
Patterns
.
Node
.
deserialize
expr
)
s
in
let
tail
=
bool
s
in
let
input
=
Types
.
deserialize
s
in
let
accept_chars
=
bool
s
in
{
brs
=
brs
;
brs_tail
=
tail
;
brs_input
=
input
;
brs_accept_chars
=
accept_chars
;
brs_compiled
=
None
}
end
compile/operators.ml
View file @
9386048d
...
...
@@ -17,6 +17,8 @@ module Unary = struct
Typer
.
mk_unary_op
:=
(
fun
name
env
->
mk
(
Proxy
.
instantiate
name
env
));;
Typer
.
typ_unary_op
:=
(
fun
i
->
fst
(
Proxy
.
content
(
value
i
)));;
Eval
.
eval_unary_op
:=
(
fun
i
->
snd
(
Proxy
.
content
(
value
i
)));;
Lambda
.
Put
.
unary_op
:=
serialize
;;
Lambda
.
Get
.
unary_op
:=
deserialize
;;
end
module
Binary
=
struct
...
...
@@ -36,4 +38,6 @@ module Binary = struct
Typer
.
mk_binary_op
:=
(
fun
name
env
->
mk
(
Proxy
.
instantiate
name
env
));;
Typer
.
typ_binary_op
:=
(
fun
i
->
fst
(
Proxy
.
content
(
value
i
)));;
Eval
.
eval_binary_op
:=
(
fun
i
->
snd
(
Proxy
.
content
(
value
i
)));;
Lambda
.
Put
.
binary_op
:=
serialize
;;
Lambda
.
Get
.
binary_op
:=
deserialize
;;
end
depend
View file @
9386048d
...
...
@@ -126,12 +126,10 @@ typing/typer.cmx: misc/q_symbol.cmo parser/ast.cmx types/atoms.cmx types/builtin
schema/schema_types.cmx schema/schema_validator.cmx types/sequence.cmx \
misc/serialize.cmx misc/state.cmx misc/stats.cmx typing/typed.cmx \
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/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
compile/lambda.cmo: misc/q_symbol.cmo types/ident.cmo types/patterns.cmi misc/serialize.cmi \
types/types.cmi
compile/lambda.cmx: misc/q_symbol.cmo types/ident.cmx types/patterns.cmx misc/serialize.cmx \
types/types.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 \
...
...
@@ -142,24 +140,34 @@ runtime/run_dispatch.cmo: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi misc
runtime/run_dispatch.cmx: misc/q_symbol.cmo types/atoms.cmx types/chars.cmx misc/encodings.cmx \
types/ident.cmx types/patterns.cmx types/types.cmx runtime/value.cmx \
runtime/run_dispatch.cmi
runtime/explain.cmo: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi misc/encodings.cmi \
types/ident.cmo types/patterns.cmi types/types.cmi runtime/value.cmi \
runtime/explain.cmi
runtime/explain.cmx: misc/q_symbol.cmo types/atoms.cmx types/chars.cmx misc/encodings.cmx \
types/ident.cmx types/patterns.cmx types/types.cmx runtime/value.cmx \
runtime/explain.cmi
runtime/print_xml.cmo: misc/q_symbol.cmo types/atoms.cmi misc/encodings.cmi types/ident.cmo \
parser/location.cmi misc/ns.cmi types/sequence.cmi runtime/value.cmi
runtime/print_xml.cmx: misc/q_symbol.cmo types/atoms.cmx misc/encodings.cmx types/ident.cmx \
parser/location.cmx misc/ns.cmx types/sequence.cmx runtime/value.cmx
runtime/eval.cmo: misc/q_symbol.cmo types/builtin_defs.cmi types/ident.cmo
types/patterns
.cm
i
\
runtime/run_dispatch.cmi schema/schema_validator.cmi \
runtime/eval.cmo: misc/q_symbol.cmo types/builtin_defs.cmi types/ident.cmo
compile/lambda
.cm
o
\
types/patterns.cmi
runtime/run_dispatch.cmi schema/schema_validator.cmi \
schema/schema_xml.cmi types/sequence.cmi typing/typed.cmo \
typing/typer.cmi types/types.cmi runtime/value.cmi runtime/eval.cmi
runtime/eval.cmx: misc/q_symbol.cmo types/builtin_defs.cmx types/ident.cmx
types/patterns
.cmx \
runtime/run_dispatch.cmx schema/schema_validator.cmx \
runtime/eval.cmx: misc/q_symbol.cmo types/builtin_defs.cmx types/ident.cmx
compile/lambda
.cmx \
types/patterns.cmx
runtime/run_dispatch.cmx schema/schema_validator.cmx \
schema/schema_xml.cmx types/sequence.cmx typing/typed.cmx \
typing/typer.cmx types/types.cmx runtime/value.cmx runtime/eval.cmi
compile/operators.cmo: misc/q_symbol.cmo misc/custom.cmo runtime/eval.cmi parser/location.cmi \
misc/pool.cmi typing/typer.cmi types/types.cmi runtime/value.cmi \
compile/operators.cmi
compile/operators.cmx: misc/q_symbol.cmo misc/custom.cmx runtime/eval.cmx parser/location.cmx \
misc/pool.cmx typing/typer.cmx types/types.cmx runtime/value.cmx \
compile/operators.cmi
compile/compile.cmo: misc/q_symbol.cmo types/ident.cmo compile/lambda.cmo types/patterns.cmi \
typing/typed.cmo types/types.cmi
compile/compile.cmx: misc/q_symbol.cmo types/ident.cmx compile/lambda.cmx types/patterns.cmx \
typing/typed.cmx types/types.cmx
compile/operators.cmo: misc/q_symbol.cmo misc/custom.cmo runtime/eval.cmi compile/lambda.cmo \
parser/location.cmi misc/pool.cmi typing/typer.cmi types/types.cmi \
runtime/value.cmi compile/operators.cmi
compile/operators.cmx: misc/q_symbol.cmo misc/custom.cmx runtime/eval.cmx compile/lambda.cmx \
parser/location.cmx misc/pool.cmx typing/typer.cmx types/types.cmx \
runtime/value.cmx compile/operators.cmi
types/builtin.cmo: misc/q_symbol.cmo types/atoms.cmi types/builtin_defs.cmi types/chars.cmi \
types/ident.cmo types/intervals.cmi runtime/load_xml.cmi \
parser/location.cmi misc/ns.cmi compile/operators.cmi \
...
...
@@ -171,15 +179,15 @@ types/builtin.cmx: misc/q_symbol.cmo types/atoms.cmx types/builtin_defs.cmx type
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 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/typed.cmo typing/typer.cmi types/types.cmi
parser/ulexer.cmi
\
runtime/value.cmi driver/cduce.cmi
runtime/eval.cmi
runtime/explain.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
runtime/eval.cmx
runtime/explain.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/state.cmi misc/stats.cmi \
parser/ulexer.cmi runtime/value.cmi
...
...
@@ -201,8 +209,8 @@ types/chars.cmi: misc/q_symbol.cmo misc/custom.cmo
types/atoms.cmi: misc/q_symbol.cmo misc/custom.cmo misc/encodings.cmi misc/ns.cmi
types/types.cmi: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi misc/custom.cmo \
types/ident.cmo types/intervals.cmi
types/patterns.cmi: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi
types/ident
.cmo \
types/types.cmi
types/patterns.cmi: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi
misc/custom
.cmo \
types/ident.cmo
types/types.cmi
types/sequence.cmi: misc/q_symbol.cmo types/atoms.cmi types/types.cmi
types/sample.cmi: misc/q_symbol.cmo types/types.cmi
types/builtin_defs.cmi: misc/q_symbol.cmo types/atoms.cmi types/ident.cmo types/types.cmi
...
...
@@ -220,7 +228,9 @@ typing/typer.cmi: misc/q_symbol.cmo parser/ast.cmo misc/custom.cmo types/ident.c
types/types.cmi
runtime/load_xml.cmi: misc/q_symbol.cmo runtime/value.cmi
runtime/run_dispatch.cmi: misc/q_symbol.cmo types/patterns.cmi runtime/value.cmi
runtime/eval.cmi: misc/q_symbol.cmo types/ident.cmo typing/typed.cmo runtime/value.cmi
runtime/explain.cmi: misc/q_symbol.cmo types/types.cmi runtime/value.cmi
runtime/eval.cmi: misc/q_symbol.cmo types/ident.cmo compile/lambda.cmo typing/typed.cmo \
runtime/value.cmi
compile/operators.cmi: misc/q_symbol.cmo misc/custom.cmo parser/location.cmi misc/serialize.cmi \
typing/typer.cmi types/types.cmi runtime/value.cmi
types/builtin.cmi: misc/q_symbol.cmo typing/typer.cmi
...
...
driver/cduce.ml
View file @
9386048d
...
...
@@ -113,6 +113,49 @@ let rec print_exn ppf = function
(* raise exn *)
Format
.
fprintf
ppf
"%a@."
print_protect
(
Printexc
.
to_string
exn
)
let
insert_bindings
ppf
=
List
.
iter2
(
fun
(
x
,
t
)
(
y
,
v
)
->
assert
(
x
=
y
);
typing_env
:=
Typer
.
enter_value
x
t
!
typing_env
;
eval_env
:=
Env
.
add
x
v
!
eval_env
;
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
eval
ppf
e
=
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
);
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
;
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
;
v
let
debug
ppf
=
function
|
`Subtype
(
t1
,
t2
)
->
Format
.
fprintf
ppf
"[DEBUG:subtype]@."
;
...
...
@@ -145,25 +188,17 @@ let debug ppf = function
let
t
=
Typer
.
typ
!
typing_env
t
and
pl
=
List
.
map
(
Typer
.
pat
!
typing_env
)
pl
in
Patterns
.
Compile
.
debug_compile
ppf
t
pl
|
`Explain
(
t
,
e
)
->
Format
.
fprintf
ppf
"[DEBUG:explain]@."
;
let
t
=
Typer
.
typ
!
typing_env
t
in
(
match
Explain
.
explain
(
Types
.
descr
t
)
(
eval
ppf
e
)
with
|
Some
p
->
Format
.
fprintf
ppf
"Explanation: @[%a@]@."
Explain
.
print_path
p
|
None
->
Format
.
fprintf
ppf
"Explanation: value has given type@."
)
let
insert_bindings
ppf
=
List
.
iter2
(
fun
(
x
,
t
)
(
y
,
v
)
->
assert
(
x
=
y
);
typing_env
:=
Typer
.
enter_value
x
t
!
typing_env
;
eval_env
:=
Env
.
add
x
v
!
eval_env
;
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
->
...
...
@@ -193,6 +228,7 @@ let rec collect_types ppf accu = function
Typer
.
enter_types
(
Typer
.
type_defs
!
typing_env
accu
)
!
typing_env
;
rest
let
rec
phrases
ppf
phs
=
match
phs
with
|
{
descr
=
Ast
.
FunDecl
_
}
::
_
->
phrases
ppf
(
collect_funs
ppf
[]
phs
)
...
...
@@ -205,25 +241,7 @@ let rec phrases ppf phs = match phs with
typing_env
:=
Typer
.
enter_ns
pr
ns
!
typing_env
;
phrases
ppf
rest
|
{
descr
=
Ast
.
EvalStatement
e
}
::
rest
->
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
);
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
);
ignore
(
eval
ppf
e
);
phrases
ppf
rest
|
{
descr
=
Ast
.
LetDecl
(
p
,
e
)
}
::
rest
->
let
decl
=
Typer
.
let_decl
!
typing_env
p
e
in
...
...
misc/serialize.ml
View file @
9386048d
...
...
@@ -68,6 +68,12 @@ module Put = struct
|
[]
->
bool
t
false
|
hd
::
tl
->
bool
t
true
;
f
t
hd
;
list
f
t
tl
let
array
f
t
a
=
int
t
(
Array
.
length
a
);
for
i
=
0
to
Array
.
length
a
-
1
do
f
t
a
.
(
i
)
done
let
pair
f1
f2
t
(
x
,
y
)
=
f1
t
x
;
f2
t
y
end
...
...
@@ -138,6 +144,16 @@ module Get = struct
if
bool
t
then
let
hd
=
f
t
in
hd
::
(
list
f
t
)
else
[]
let
array
f
t
=
let
n
=
int
t
in
if
n
=
0
then
[
|
|
]
else
let
a
=
Array
.
create
n
(
f
t
)
in
for
i
=
1
to
Array
.
length
a
-
1
do
a
.
(
i
)
<-
f
t
done
;
a
let
pair
f1
f2
t
=
let
x
=
f1
t
in
let
y
=
f2
t
in
...
...
misc/serialize.mli
View file @
9386048d
...
...
@@ -10,6 +10,7 @@ module Put : sig
val
bool
:
bool
f
val
list
:
'
a
f
->
'
a
list
f
val
array
:
'
a
f
->
'
a
array
f
val
pair
:
'
a
f
->
'
b
f
->
(
'
a
*
'
b
)
f
type
'
b
property
...
...
@@ -30,6 +31,7 @@ module Get : sig
val
bool
:
bool
f
val
list
:
'
a
f
->
'
a
list
f
val
array
:
'
a
f
->
'
a
array
f
val
pair
:
'
a
f
->
'
b
f
->
(
'
a
*
'
b
)
f
type
'
b
property
...
...
parser/ast.ml
View file @
9386048d
...
...
@@ -23,6 +23,7 @@ and debug_directive =
|
`Accept
of
ppat
|
`Compile
of
ppat
*
ppat
list
|
`Subtype
of
ppat
*
ppat
|
`Explain
of
ppat
*
pexpr
]
and
toplevel_directive
=
[
`Quit
...
...
parser/parser.ml
View file @
9386048d
...
...
@@ -92,15 +92,13 @@ EXTEND
[
l
=
LIST0
[
p
=
phrase
;
OPT
";;"
->
p
];
EOI
->
List
.
flatten
l
]
];
uident
:
[
[
x
=
IDENT
->
ident
x
]
];
phrase
:
[
[
(
f
,
p
,
e
)
=
let_binding
->
if
f
then
[
mk
loc
(
FunDecl
e
)
]
else
[
mk
loc
(
LetDecl
(
p
,
e
))
]
|
(
_
,
p
,
e1
)
=
let_binding
;
"in"
;
e2
=
expr
LEVEL
"top"
->
[
mk
loc
(
EvalStatement
(
exp
loc
(
Match
(
e1
,
[
p
,
e2
]))))
]
|
"type"
;
x
=
uident
;
"="
;
t
=
pat
->
[
mk
loc
(
TypeDecl
(
x
,
t
))
]
|
"type"
;
x
=
IDENT
;
"="
;
t
=
pat
->
[
mk
loc
(
TypeDecl
(
ident
x
,
t
))
]
|
"schema"
;
name
=
IDENT
;
"="
;
uri
=
STRING2
->
protect_op
"schema"
;
let
schema_doc
=
Schema_xml
.
pxp_tree_of
uri
in
...
...
@@ -157,6 +155,7 @@ EXTEND
|
IDENT
"compile"
;
t
=
pat
;
p
=
LIST1
pat
->
`Compile
(
t
,
p
)
|
IDENT
"sample"
;
t
=
pat
->
`Sample
t
|
IDENT
"subtype"
;
t1
=
pat
;
t2
=
pat
->
`Subtype
(
t1
,
t2
)
|
IDENT
"explain"
;
t
=
pat
;
e
=
expr
->
`Explain
(
t
,
e
)
]
];
...
...
@@ -288,7 +287,7 @@ EXTEND
|
s
=
STRING2
->
let
s
=
U
.
mk
s
in
exp
loc
(
String
(
U
.
start_index
s
,
U
.
end_index
s
,
s
,
cst_nil
))
|
a
=
uident
->
exp
loc
(
Var
a
)
|
a
=
IDENT
->
exp
loc
(
Var
(
ident
a
)
)
|
"!"
;
e
=
expr
->
exp
loc
(
Apply
(
Dot
(
e
,
U
.
mk
"get"
)
,
cst_nil
))
|
i
=
INT
->
exp
loc
(
Integer
(
Intervals
.
V
.
mk
i
))
...
...
@@ -398,9 +397,16 @@ EXTEND
|
x
=
regexp
;
"+?"
->
Seq
(
x
,
WeakStar
x
)
|
x
=
regexp
;
"?"
->
Alt
(
x
,
Epsilon
)
|
x
=
regexp
;
"??"
->
Alt
(
Epsilon
,
x
)
]
|
[
"("
;
x
=
regexp
;
")"
->
x
|
"("
;
a
=
uident
;
":="
;
c
=
expr
;
")"
->
Elem
(
mk
loc
(
Constant
((
a
,
c
))))
|
[
"("
;
x
=
LIST1
regexp
SEP
","
;
")"
->
let
x
=
List
.
map
(
function
|
Elem
x
->
x
|
_
->
error
loc
"Mixing regular expressions and products"
)
x
in
Elem
(
multi_prod
loc
x
)
|
"("
;
a
=
IDENT
;
":="
;
c
=
expr
;
")"
->
Elem
(
mk
loc
(
Constant
((
ident
a
,
c
))))
|
IDENT
"PCDATA"
->
string_regexp
|
i
=
STRING1
;
"--"
;
j
=
STRING1
->
let
i
=
Chars
.
V
.
mk_int
(
parse_char
loc
i
)
...
...
@@ -420,7 +426,7 @@ EXTEND
pat
:
[
[
x
=
pat
;
IDENT
"where"
;
b
=
LIST1
[
a
=
uident
;
"="
;
y
=
pat
->
(
a
,
y
)
]
SEP
"and"
b
=
LIST1
[
a
=
IDENT
;
"="
;
y
=
pat
->
(
ident
a
,
y
)
]
SEP
"and"
->
mk
loc
(
Recurs
(
x
,
b
))
]
|
RIGHTA
[
x
=
pat
;
"->"
;
y
=
pat
->
mk
loc
(
Arrow
(
x
,
y
))
]
|
"no_arrow"
[
x
=
pat
;
"|"
;
y
=
pat
->
mk
loc
(
Or
(
x
,
y
))
]
...
...
@@ -448,8 +454,8 @@ EXTEND
|
_
->
assert
false
in
mk
loc
(
SchemaVar
(
kind
,
schema
,
typ
))
|
a
=
uident
->
mk
loc
(
PatVar
a
)
|
a
=
IDENT
->
mk
loc
(
PatVar
(
ident
a
)
)
|
i
=
INT
;
"--"
;
j
=
INT
->
let
i
=
Intervals
.
V
.
mk
i
and
j
=
Intervals
.
V
.
mk
j
in
...
...
runtime/explain.ml
0 → 100644
View file @
9386048d
open
Value
open
Ident
open
Patterns
.
Compile
open
Encodings