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
50e4a083
Commit
50e4a083
authored
Oct 05, 2007
by
Pietro Abate
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[r2003-10-04 02:00:15 by cvscast] Compilation + serialization
Original author: cvscast Date: 2003-10-04 02:01:37+00:00
parent
ee4bddf0
Changes
29
Hide whitespace changes
Inline
Side-by-side
Showing
29 changed files
with
534 additions
and
206 deletions
+534
-206
Makefile.distrib
Makefile.distrib
+4
-1
compile/compile.ml
compile/compile.ml
+70
-6
compile/compile.mli
compile/compile.mli
+8
-5
compile/lambda.ml
compile/lambda.ml
+42
-6
depend
depend
+8
-5
driver/cduce.ml
driver/cduce.ml
+77
-36
driver/cduce.mli
driver/cduce.mli
+4
-0
driver/run.ml
driver/run.ml
+79
-39
misc/bool.ml
misc/bool.ml
+1
-3
misc/custom.ml
misc/custom.ml
+1
-1
misc/serialize.ml
misc/serialize.ml
+12
-0
misc/serialize.mli
misc/serialize.mli
+2
-0
parser/location.ml
parser/location.ml
+2
-0
parser/parser.ml
parser/parser.ml
+9
-0
runtime/eval.ml
runtime/eval.ml
+23
-14
runtime/eval.mli
runtime/eval.mli
+3
-4
types/atoms.ml
types/atoms.ml
+35
-33
types/builtin.ml
types/builtin.ml
+5
-1
types/chars.ml
types/chars.ml
+0
-1
types/intervals.ml
types/intervals.ml
+10
-1
types/patterns.ml
types/patterns.ml
+21
-8
types/patterns.mli
types/patterns.mli
+10
-1
types/sortedList.ml
types/sortedList.ml
+10
-1
types/types.ml
types/types.ml
+35
-8
types/types.mli
types/types.mli
+1
-0
typing/typed.ml
typing/typed.ml
+1
-1
typing/typer.ml
typing/typer.ml
+46
-11
typing/typer.mli
typing/typer.mli
+10
-15
web/site.cd
web/site.cd
+5
-5
No files found.
Makefile.distrib
View file @
50e4a083
...
...
@@ -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 @
50e4a083
...
...
@@ -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 @
50e4a083
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
->
Typed
.
texpr
list
->
env
*
Lambda
.
expr
list
val
comp
_unit
:
Typer
.
t
->
env
->
Ast
.
pmodule_item
list
->
Typer
.
t
*
env
*
Lambda
.
code_item
list
compile/lambda.ml
View file @
50e4a083
...
...
@@ -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 @
50e4a083
...
...
@@ -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 @
50e4a083
...
...
@@ -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 @
50e4a083
...
...
@@ -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 @
50e4a083
...
...
@@ -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 @
50e4a083
...
...
@@ -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 @
50e4a083
...
...
@@ -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 @
50e4a083
...
...
@@ -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
let
string
t
s
=
substring
t
s
0
(
String
.
length
s
)
let
magic
t
s
=
for
i
=
0
to
String
.
length
s
-
1
do
bits
8
t
(
Char
.
code
(
s
.
[
i
]))
done
let
rec
list
f
t
=
function
|
[]
->
bool
t
false
|
hd
::
tl
->
bool
t
true
;
f
t
hd
;
list
f
t
tl
...
...
@@ -140,6 +146,12 @@ module Get = struct
done
;
s
let
magic
t
s
=
for
i
=
0
to
String
.
length
s
-
1
do
let
c
=
bits
8
t
in
if
(
Char
.
code
(
s
.
[
i
])
!=
c
)
then
failwith
"Invalid magic code."
done
let
rec
list
f
t
=
if
bool
t
then
let
hd
=
f
t
in
hd
::
(
list
f
t
)
else
[]
...
...