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
3385c1e7
Commit
3385c1e7
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2003-10-04 02:00:15 by cvscast] Compilation + serialization
Original author: cvscast Date: 2003-10-04 02:01:37+00:00
parent
109fe5d6
Changes
29
Hide whitespace changes
Inline
Side-by-side
Makefile.distrib
View file @
3385c1e7
...
...
@@ -26,7 +26,7 @@ endif
SYNTAX_PARSER
=
-syntax
camlp4o
$
(
SYNTAX:%
=
-ppopt
%
)
CAMLC_P
=
ocamlc
CAMLC_P
=
ocamlc
-g
DEPEND_OCAMLDEP
=
misc/q_symbol.cmo
ifeq
($(PROFILE), true)
CAMLOPT_P
=
ocamlopt
-p
...
...
@@ -117,6 +117,9 @@ INCLUDES = $(DIRS:%=-I %)
cduce
:
$(CDUCE:.cmo=.$(EXTENSION))
$(LINK)
$(INCLUDES)
-o
$@
$^
bug
:
$(OBJECTS) bug.cmo
$(LINK)
$(INCLUDES)
-o
$@
$^
webiface
:
$(WEBIFACE:.cmo=.$(EXTENSION))
$(LINK)
$(INCLUDES)
-o
$@
$^
-ccopt
-static
# webiface is made static to be able to move it more easily
...
...
compile/compile.ml
View file @
3385c1e7
...
...
@@ -83,7 +83,7 @@ and compile_branch env tail br =
{
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
)
env
(
Patterns
.
fv
_list
br
.
Typed
.
br_pat
)
in
(
br
.
Typed
.
br_pat
,
compile
env
tail
br
.
Typed
.
br_body
)
...
...
@@ -93,12 +93,13 @@ let enter_global env x =
let
enter_globals
=
List
.
fold_left
enter_global
let
compile_eval
env
e
=
Eval
(
compile
env
false
e
)
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
(
env
,
decl
)
let
code
=
Let_decl
(
pat
,
compile
env
false
(
decl
.
Typed
.
let_body
))
in
let
env
=
enter_globals
env
(
Patterns
.
fv_list
pat
)
in
(
env
,
code
)
let
compile_rec_funs
env
funs
=
...
...
@@ -111,4 +112,67 @@ let compile_rec_funs env funs =
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
(
env
,
exprs
)
(
env
,
Let_funs
exprs
)
(****************************************)
open
Location
let
eval
(
tenv
,
cenv
,
codes
)
e
=
let
(
e
,_
)
=
Typer
.
type_expr
tenv
e
in
let
code
=
compile_eval
cenv
e
in
(
tenv
,
cenv
,
code
::
codes
)
let
let_decl
(
tenv
,
cenv
,
codes
)
p
e
=
let
(
tenv
,
decl
,_
)
=
Typer
.
type_let_decl
tenv
p
e
in
let
(
cenv
,
code
)
=
compile_let_decl
cenv
decl
in
(
tenv
,
cenv
,
code
::
codes
)
let
let_funs
(
tenv
,
cenv
,
codes
)
funs
=
let
(
tenv
,
funs
,_
)
=
Typer
.
type_let_funs
tenv
funs
in
let
(
cenv
,
code
)
=
compile_rec_funs
cenv
funs
in
(
tenv
,
cenv
,
code
::
codes
)
let
type_defs
(
tenv
,
cenv
,
codes
)
typs
=
let
tenv
=
Typer
.
enter_types
(
Typer
.
type_defs
tenv
typs
)
tenv
in
(
tenv
,
cenv
,
codes
)
let
namespace
(
tenv
,
cenv
,
codes
)
pr
ns
=
let
tenv
=
Typer
.
enter_ns
pr
ns
tenv
in
(
tenv
,
cenv
,
codes
)
let
rec
collect_funs
accu
=
function
|
{
descr
=
Ast
.
FunDecl
e
}
::
rest
->
collect_funs
(
e
::
accu
)
rest
|
rest
->
(
accu
,
rest
)
let
rec
collect_types
accu
=
function
|
{
descr
=
Ast
.
TypeDecl
(
x
,
t
)
}
::
rest
->
collect_types
((
x
,
t
)
::
accu
)
rest
|
rest
->
(
accu
,
rest
)
let
rec
phrases
accu
phs
=
match
phs
with
|
{
descr
=
Ast
.
FunDecl
_
}
::
_
->
let
(
funs
,
rest
)
=
collect_funs
[]
phs
in
phrases
(
let_funs
accu
funs
)
rest
|
{
descr
=
Ast
.
TypeDecl
(
_
,_
)
}
::
_
->
let
(
typs
,
rest
)
=
collect_types
[]
phs
in
phrases
(
type_defs
accu
typs
)
rest
|
{
descr
=
Ast
.
SchemaDecl
(
name
,
schema
)
}
::
rest
->
Typer
.
register_schema
name
schema
;
phrases
accu
rest
|
{
descr
=
Ast
.
Namespace
(
pr
,
ns
)
}
::
rest
->
phrases
(
namespace
accu
pr
ns
)
rest
|
{
descr
=
Ast
.
EvalStatement
e
}
::
rest
->
phrases
(
eval
accu
e
)
rest
|
{
descr
=
Ast
.
LetDecl
(
p
,
e
)
}
::
rest
->
phrases
(
let_decl
accu
p
e
)
rest
|
{
descr
=
Ast
.
Debug
l
}
::
rest
->
phrases
accu
rest
|
{
descr
=
Ast
.
Directive
_
}
::
rest
->
phrases
accu
rest
|
[]
->
accu
let
comp_unit
tenv
cenv
phs
=
let
(
tenv
,
cenv
,
codes
)
=
phrases
(
tenv
,
cenv
,
[]
)
phs
in
(
tenv
,
cenv
,
List
.
rev
codes
)
compile/compile.mli
View file @
3385c1e7
open
Ident
open
Lambda
type
env
val
empty
:
env
val
enter_global
:
env
->
id
->
env
val
enter_globals
:
env
->
id
list
->
env
val
find
:
id
->
env
->
Lambda
.
var_loc
val
find
:
id
->
env
->
var_loc
val
compile
:
env
->
bool
->
Typed
.
texpr
->
Lambda
.
expr
val
compile_eval
:
env
->
Typed
.
texpr
->
code_item
val
compile_let_decl
:
env
->
Typed
.
let_decl
->
env
*
code_item
val
compile_rec_funs
:
env
->
Typed
.
texpr
list
->
env
*
code_item
val
comp
ile_let_decl
:
env
->
Typed
.
let_decl
->
env
*
Lambda
.
let_decl
val
compile_rec_funs
:
env
->
Type
d
.
t
expr
list
->
env
*
Lambda
.
expr
list
val
comp
_unit
:
Type
r
.
t
->
env
->
Ast
.
pmodule_item
list
->
Typer
.
t
*
env
*
Lambda
.
code_item
list
compile/lambda.ml
View file @
3385c1e7
...
...
@@ -38,14 +38,23 @@ and branches = {
(
Patterns
.
Compile
.
dispatcher
*
expr
Patterns
.
Compile
.
rhs
array
)
option
}
type
let_decl
=
{
let_pat
:
Patterns
.
node
;
let_expr
:
expr
;
}
type
code_item
=
|
Eval
of
expr
|
Let_decl
of
Patterns
.
node
*
expr
|
Let_funs
of
expr
list
let
print_code_item
ppf
=
function
|
Eval
_
->
Format
.
fprintf
ppf
"Eval@."
|
Let_decl
_
->
Format
.
fprintf
ppf
"Let_decl@."
|
Let_funs
_
->
Format
.
fprintf
ppf
"Let_funs@."
type
code
=
code_item
list
let
nbits
=
5
let
magic_compunit
=
"CDUCE:0.2:COMPUNIT"
module
Put
=
struct
let
unary_op
=
ref
(
fun
_
_
->
assert
false
;
()
)
let
binary_op
=
ref
(
fun
_
_
->
assert
false
;
()
)
...
...
@@ -119,7 +128,7 @@ module Put = struct
expr
s
e
;
branches
s
brs
|
Validate
(
e
,
sch
,
t
)
->
assert
false
(* Need to store a pointer to the schema ... *)
assert
false
(*
TODO:
Need to store a pointer to the schema ... *)
|
RemoveField
(
e
,
l
)
->
bits
nbits
s
14
;
expr
s
e
;
...
...
@@ -147,7 +156,17 @@ module Put = struct
bool
s
brs
.
brs_tail
;
Types
.
serialize
s
brs
.
brs_input
;
bool
s
brs
.
brs_accept_chars
let
code_item
s
=
function
|
Eval
e
->
bits
2
s
0
;
expr
s
e
|
Let_decl
(
p
,
e
)
->
bits
2
s
1
;
Patterns
.
Node
.
serialize
s
p
;
expr
s
e
|
Let_funs
e
->
bits
2
s
2
;
list
expr
s
e
let
codes
=
list
code_item
let
compunit
s
c
=
magic
s
magic_compunit
;
codes
s
c
end
...
...
@@ -247,4 +266,21 @@ module Get = struct
brs_compiled
=
None
}
let
code_item
s
=
match
bits
2
s
with
|
0
->
Eval
(
expr
s
)
|
1
->
let
p
=
Patterns
.
Node
.
deserialize
s
in
let
e
=
expr
s
in
Let_decl
(
p
,
e
)
|
2
->
Let_funs
(
list
expr
s
)
|
_
->
assert
false
let
codes
=
list
code_item
let
compunit
s
=
magic
s
magic_compunit
;
codes
s
end
depend
View file @
3385c1e7
...
...
@@ -158,10 +158,12 @@ runtime/eval.cmx: misc/q_symbol.cmo types/builtin_defs.cmx types/ident.cmx compi
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/compile.cmo: misc/q_symbol.cmo types/ident.cmo compile/lambda.cmo types/patterns.cmi \
typing/typed.cmo types/types.cmi compile/compile.cmi
compile/compile.cmx: misc/q_symbol.cmo types/ident.cmx compile/lambda.cmx types/patterns.cmx \
typing/typed.cmx types/types.cmx compile/compile.cmi
compile/compile.cmo: misc/q_symbol.cmo parser/ast.cmo types/builtin.cmi types/ident.cmo \
compile/lambda.cmo parser/location.cmi types/patterns.cmi \
typing/typed.cmo typing/typer.cmi types/types.cmi compile/compile.cmi
compile/compile.cmx: misc/q_symbol.cmo parser/ast.cmx types/builtin.cmx types/ident.cmx \
compile/lambda.cmx parser/location.cmx types/patterns.cmx \
typing/typed.cmx typing/typer.cmx types/types.cmx compile/compile.cmi
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
...
...
@@ -231,7 +233,8 @@ runtime/run_dispatch.cmi: misc/q_symbol.cmo types/patterns.cmi 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/compile.cmi: misc/q_symbol.cmo types/ident.cmo compile/lambda.cmo typing/typed.cmo
compile/compile.cmi: misc/q_symbol.cmo parser/ast.cmo types/ident.cmo compile/lambda.cmo \
typing/typed.cmo typing/typer.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 @
3385c1e7
...
...
@@ -12,7 +12,7 @@ let do_compile = ref false
let
get_global_value
v
=
if
!
do_compile
then
Eval
.
L
.
eval_
var
(
Compile
.
find
v
!
compile_env
)
then
Eval
.
L
.
var
(
Compile
.
find
v
!
compile_env
)
else
Eval
.
find_value
v
!
eval_env
let
get_global_type
v
=
...
...
@@ -119,17 +119,15 @@ let display ppf l =
l
let
eval
ppf
e
=
let
e
=
Typer
.
expr
!
typing_env
e
in
let
t
=
Typer
.
type_check
!
typing_env
e
Types
.
any
true
in
Typer
.
report_unused_branches
()
;
let
(
e
,
t
)
=
Typer
.
type_expr
!
typing_env
e
in
if
not
!
quiet
then
Location
.
dump_loc
ppf
(
e
.
Typed
.
exp_loc
,
`Full
);
let
v
=
if
!
do_compile
then
let
e
=
Compile
.
compile
!
compile_env
false
e
in
Eval
.
L
.
e
val
e
let
e
=
Compile
.
compile
_eval
!
compile_env
e
in
Eval
.
L
.
e
xpr
e
else
Eval
.
eval
!
eval_env
e
in
...
...
@@ -139,36 +137,32 @@ let eval ppf e =
v
let
let_decl
ppf
p
e
=
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
(
tenv
,
decl
,
typs
)
=
Typer
.
type_let_decl
!
typing_env
p
e
in
let
()
=
if
!
do_compile
then
let
(
env
,
decl
)
=
Compile
.
compile_let_decl
!
compile_env
decl
in
Eval
.
L
.
eval
_let_decl
decl
;
Eval
.
L
.
eval
decl
;
compile_env
:=
env
else
eval_env
:=
Eval
.
eval_let_decl
!
eval_env
decl
in
typing_env
:=
Typer
.
enter_values
typs
!
typing_
env
;
typing_env
:=
t
env
;
display
ppf
typs
let
let_funs
ppf
funs
=
let
funs
=
List
.
map
(
Typer
.
expr
!
typing_env
)
funs
in
let
typs
=
Typer
.
type_rec_funs
!
typing_env
funs
in
Typer
.
report_unused_branches
()
;
let
(
tenv
,
funs
,
typs
)
=
Typer
.
type_let_funs
!
typing_env
funs
in
let
()
=
if
!
do_compile
then
let
(
env
,
funs
)
=
Compile
.
compile_rec_funs
!
compile_env
funs
in
Eval
.
L
.
eval
_rec_funs
funs
;
Eval
.
L
.
eval
funs
;
compile_env
:=
env
;
else
eval_env
:=
Eval
.
eval_rec_funs
!
eval_env
funs
in
typing_env
:=
Typer
.
enter_values
typs
!
typing_
env
;
typing_env
:=
t
env
;
display
ppf
typs
...
...
@@ -259,31 +253,78 @@ let rec phrases ppf phs = match phs with
phrases
ppf
rest
|
[]
->
()
let
catch_exn
ppf_err
=
function
|
(
End_of_file
|
Failure
_
|
Not_found
|
Invalid_argument
_
|
Sys
.
Break
)
as
e
->
raise
e
|
exn
->
print_exn
ppf_err
exn
;
Format
.
fprintf
ppf_err
"@."
let
parse
rule
input
=
try
Some
(
rule
input
)
with
|
Stdpp
.
Exc_located
(
_
,
(
Location
_
as
e
))
->
Parser
.
sync
()
;
raise
e
|
Stdpp
.
Exc_located
((
i
,
j
)
,
e
)
->
Parser
.
sync
()
;
raise_loc
i
j
e
let
run
rule
ppf
ppf_err
input
=
Typer
.
clear_unused_branches
()
;
try
let
p
=
try
rule
input
with
|
Stdpp
.
Exc_located
(
_
,
(
Location
_
as
e
))
->
Parser
.
sync
()
;
raise
e
|
Stdpp
.
Exc_located
((
i
,
j
)
,
e
)
->
Parser
.
sync
()
;
raise_loc
i
j
e
in
phrases
ppf
p
;
true
with
|
(
End_of_file
|
Failure
_
|
Not_found
|
Invalid_argument
_
|
Sys
.
Break
)
as
e
->
raise
e
|
exn
->
print_exn
ppf_err
exn
;
Format
.
fprintf
ppf_err
"@."
;
false
try
match
parse
rule
input
with
|
Some
phs
->
phrases
ppf
phs
;
true
|
None
->
false
with
exn
->
catch_exn
ppf_err
exn
;
false
let
script
=
run
Parser
.
prog
let
topinput
=
run
Parser
.
top_phrases
let
comp_unit
src
=
try
let
ic
=
open_in
src
in
Location
.
push_source
(
`File
src
);
let
input
=
Stream
.
of_channel
ic
in
match
parse
Parser
.
prog
input
with
|
Some
p
->
close_in
ic
;
let
argv
=
ident
(
U
.
mk
"argv"
)
in
let
(
tenv
,
cenv
,
codes
)
=
Compile
.
comp_unit
(
Typer
.
enter_value
argv
(
Sequence
.
star
Sequence
.
string
)
Builtin
.
env
)
(
Compile
.
enter_global
Compile
.
empty
argv
)
p
in
codes
|
None
->
exit
1
with
exn
->
catch_exn
Format
.
err_formatter
exn
;
exit
1
let
run_code
argv
codes
=
try
Eval
.
L
.
push
argv
;
List
.
iter
Eval
.
L
.
eval
codes
with
exn
->
catch_exn
Format
.
err_formatter
exn
;
exit
1
let
compile
src
=
let
codes
=
comp_unit
src
in
let
oc
=
open_out
(
src
^
".out"
)
in
let
codes_s
=
Serialize
.
Put
.
run
Lambda
.
Put
.
compunit
codes
in
output_string
oc
codes_s
;
close_out
oc
;
exit
0
let
compile_run
src
argv
=
run_code
argv
(
comp_unit
src
)
let
run
obj
argv
=
let
ic
=
open_in
obj
in
let
len
=
in_channel_length
ic
in
let
codes
=
String
.
create
len
in
really_input
ic
codes
0
len
;
close_in
ic
;
let
codes
=
Serialize
.
Get
.
run
Lambda
.
Get
.
compunit
codes
in
run_code
argv
codes
let
serialize_typing_env
t
()
=
Typer
.
serialize
t
!
typing_env
...
...
driver/cduce.mli
View file @
3385c1e7
...
...
@@ -10,3 +10,7 @@ val dump_env : Format.formatter -> unit
val
serialize_typing_env
:
Serialize
.
Put
.
t
->
unit
->
unit
val
deserialize_typing_env
:
Serialize
.
Get
.
t
->
unit
val
compile
:
string
->
unit
val
compile_run
:
string
->
Value
.
t
->
unit
val
run
:
string
->
Value
.
t
->
unit
driver/run.ml
View file @
3385c1e7
...
...
@@ -8,6 +8,9 @@ let save_dump = ref None
let
src
=
ref
[]
let
args
=
ref
[]
let
compile
=
ref
false
let
run
=
ref
false
let
version
()
=
Printf
.
eprintf
"CDuce, version %s
\n
"
<:
symbol
<
cduce_version
>>;
Printf
.
eprintf
"built on %s
\n
"
<:
symbol
<
build_date
>>;
...
...
@@ -32,8 +35,10 @@ 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"
;
"--compile"
,
Arg
.
Set
compile
,
" compilate the given CDuce file"
;
"--run"
,
Arg
.
Set
run
,
" compilate the given CDuce file"
;
"--stdin"
,
Arg
.
Unit
(
fun
()
->
src
:=
""
::
!
src
)
,
" read CDuce script on standard input"
;
"--verbose"
,
Arg
.
Unit
(
fun
()
->
Stats
.
set_verbosity
Stats
.
Summary
)
,
...
...
@@ -54,6 +59,7 @@ let ppf =
else
Format
.
std_formatter
let
ppf_err
=
Format
.
err_formatter
let
specs
=
if
Load_xml
.
expat_support
then
(
"--expat"
,
Arg
.
Unit
(
fun
()
->
Load_xml
.
use_parser
:=
`Expat
)
,
...
...
@@ -69,9 +75,33 @@ let specs =
specs
let
()
=
let
err
s
=
prerr_endline
s
;
exit
1
let
mode
=
Arg
.
parse
specs
(
fun
s
->
src
:=
s
::
!
src
)
"
\n
Usage:
\n
cduce [OPTIONS ...] [FILE ...] [--arg argument ...]
\n\n
Options:"
"Usage:
\n
cduce [OPTIONS ...] [FILE ...] [--arg argument ...]
\n\n
Options:"
;
match
(
!
compile
,!
run
,!
src
,!
args
)
with
|
false
,
false
,
[]
,
args
->
`Toplevel
args
|
false
,
false
,
[
x
]
,
args
->
`Script
(
x
,
args
)
|
false
,
false
,
_
,
_
->
err
"Only one CDuce program can be executed at a time"
|
true
,
false
,
[
x
]
,
[]
->
`Compile
x
|
true
,
false
,
[]
,
[]
->
err
"Please specifiy the CDuce program to be compiled"
|
true
,
false
,
_
,
[]
->
err
"Only one CDuce program can be compiled at a time"
|
true
,
false
,
_
,
_
->
err
"No argument can be passed to programs at compile time"
|
false
,
true
,
[
x
]
,
args
->
`Run
(
x
,
args
)
|
false
,
true
,
[]
,
_
->
err
"Please specifiy the CDuce program to be executed"
|
false
,
true
,
_
,
_
->
err
"Only one CDuce program can be executed at a time"
|
true
,
true
,
_
,
_
->
err
"The options --compile and --run are incompatible"
let
bol
=
ref
true
...
...
@@ -137,41 +167,51 @@ let do_stdin () =
let
run
s
=
if
s
=
""
then
do_stdin
()
else
do_file
s
let
main
()
=
(
match
!
load_dump
with
|
Some
f
->
(
try
Format
.
fprintf
ppf
"Restoring state: "
;
let
chan
=
open_in_bin
f
in
let
s
=
Marshal
.
from_channel
chan
in
close_in
chan
;
(* Serialize.Get.run Cduce.deserialize_typing_env s; *)
State
.
set
s
;
Format
.
fprintf
ppf
"done ...@."
with
Sys_error
_
->
Format
.
fprintf
ppf
"failed ...@."
)
|
None
->
let
l
=
List
.
rev_map
Value
.
string_latin1
!
args
in
let
l
=
Value
.
sequence
l
in
let
t
=
Sequence
.
star
Sequence
.
string
in
Cduce
.
enter_global_value
(
ident
(
U
.
mk
"argv"
))
l
t
);
(
match
!
src
with
|
[]
->
toploop
()
|
l
->
List
.
iter
run
l
);
(
match
!
save_dump
with
|
Some
f
->
Format
.
fprintf
ppf
"Saving state ...@
\n
"
;
(* let s = Serialize.Put.run Cduce.serialize_typing_env () in *)
let
s
=
State
.
get
()
in
let
chan
=
open_out_bin
f
in
Marshal
.
to_channel
chan
s
[
Marshal
.
Closures
];
close_out
chan
|
None
->
()
)
let
()
=
let
argv
args
=
Value
.
sequence
(
List
.
rev_map
Value
.
string_latin1
args
)
let
restore
argv
=
match
!
load_dump
with
|
Some
f
->
(
try
Format
.
fprintf
ppf
"Restoring state: "
;
let
chan
=
open_in_bin
f
in
let
s
=
Marshal
.
from_channel
chan
in
close_in
chan
;
(* Serialize.Get.run Cduce.deserialize_typing_env s; *)
State
.
set
s
;
Format
.
fprintf
ppf
"done ...@."
with
Sys_error
_
->
Format
.
fprintf
ppf
"failed ...@."
)
|
None
->
let
t
=
Sequence
.
star
Sequence
.
string
in
Cduce
.
enter_global_value
(
ident
(
U
.
mk
"argv"
))
argv
t
let
save
()
=
match
!
save_dump
with
|
Some
f
->
Format
.
fprintf
ppf
"Saving state ...@
\n
"
;
(* let s = Serialize.Put.run Cduce.serialize_typing_env () in *)
let
s
=
State
.
get
()
in
let
chan
=
open_out_bin
f
in
Marshal
.
to_channel
chan
s
[
Marshal
.
Closures
];
close_out
chan
|
None
->
()
let
main
()
=
match
mode
with
|
`Toplevel
args
->
restore
(
argv
args
);
toploop
()
;
save
()
|
`Script
(
f
,
args
)
->
Cduce
.
compile_run
f
(
argv
args
)
|
`Compile
f
->
Cduce
.
compile
f
|
`Run
(
f
,
args
)
->
Cduce
.
run
f
(
argv
args
)
let
()
=
at_exit
(
fun
()
->
Stats
.
dump
Format
.
std_formatter
);
main
()
...
...
misc/bool.ml
View file @
3385c1e7
...
...
@@ -32,8 +32,6 @@ struct
|
False
|
Split
of
int
*
elem
*
t
*
t
*
t
include
Custom
.
Dummy
let
rec
equal
a
b
=
(
a
==
b
)
||
match
(
a
,
b
)
with
...
...
@@ -78,7 +76,7 @@ struct
(
match
p
with
Split
(
_
,
y
,_,_,_
)
->
assert
(
X
.
compare
x
y
<
0
)
|
_
->
()
);
(
match
i
with
Split
(
_
,
y
,_,_,_
)
->
assert
(
X
.
compare
x
y
<
0
)
|
_
->
()
);
(
match
n
with
Split
(
_
,
y
,_,_,_
)
->
assert
(
X
.
compare
x
y
<
0
)
|
_
->
()
);
check
p
;
check
i
;
check
n
X
.
check
x
;
check
p
;
check
i
;
check
n
let
atom
x
=
let
h
=
X
.
hash
x
+
17
in
(* partial evaluation of compute_hash... *)
...
...
misc/custom.ml
View file @
3385c1e7
...
...
@@ -21,7 +21,7 @@ module Dummy = struct
let
equal
t1
t2
=
failwith
"equal not implemented"
let
hash
t
=
failwith
"hash not implemented"
let
compare
t1
t2
=
failwith
"compare not implemented"
let
serialize
t
=
failwith
"serialize not implemented"
let
serialize
t
=
failwith
"serialize not implemented"
let
deserialize
t
=
failwith
"deserialize not implemented"
end
...
...
misc/serialize.ml
View file @
3385c1e7
...
...
@@ -51,6 +51,7 @@ module Put = struct
(* TODO: handle negative ints better !! *)
let
rec
int
t
i
=
assert
(
i
>=
0
);
bits
4
t
i
;
let
i
=
i
lsr
4
in
if
i
<>
0
then
(
bool
t
true
;
int
t
i
)
else
(
bool
t
false
)
...
...
@@ -64,6 +65,11 @@ module Put = struct