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
5380b16c
Commit
5380b16c
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2003-12-13 13:51:19 by afrisch] Factorization + --verbose
Original author: afrisch Date: 2003-12-13 13:51:20+00:00
parent
5e8c8295
Changes
13
Hide whitespace changes
Inline
Side-by-side
Makefile.distrib
View file @
5380b16c
...
...
@@ -242,7 +242,7 @@ include depend
# CDuce-generated files
driver/examples.ml
:
cduce web/examples/build.cd web/examples/examples.xml
(
cd
web/examples
;
../../cduce
--quiet
build.cd
--arg
examples.xml
)
(
cd
web/examples
;
../../cduce build.cd
--arg
examples.xml
)
webpages
:
cduce web/site.cdo
(
cd
web
;
../cduce
--run
site.cdo
--arg
site.xml
)
...
...
compile/compile.ml
View file @
5380b16c
...
...
@@ -6,6 +6,13 @@ type env = {
stack_size
:
int
}
let
dump
ppf
env
=
Env
.
iter
(
fun
id
loc
->
Format
.
fprintf
ppf
"Var %a : %a@
\n
"
U
.
print
(
Id
.
value
id
)
Lambda
.
print_var_loc
loc
)
env
.
vars
let
empty
=
{
vars
=
Env
.
empty
;
stack_size
=
0
}
let
serialize
s
env
=
...
...
@@ -141,20 +148,40 @@ let compile_rec_funs env funs =
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
eval
~
run
~
show
(
tenv
,
cenv
,
codes
)
e
=
let
(
e
,
t
)
=
Typer
.
type_expr
tenv
e
in
let
code
=
compile_eval
cenv
e
in
if
run
then
let
v
=
Eval
.
expr
code
in
show
None
t
(
Some
v
)
else
show
None
t
None
;
(
tenv
,
cenv
,
code
::
codes
)
let
run_show
~
run
~
show
tenv
cenv
code
ids
=
if
run
then
let
()
=
Eval
.
eval
code
in
List
.
iter
(
fun
(
id
,_
)
->
show
(
Some
id
)
(
Typer
.
find_value
id
tenv
)
(
Some
(
Eval
.
var
(
find
id
cenv
))))
ids
else
List
.
iter
(
fun
(
id
,_
)
->
show
(
Some
id
)
(
Typer
.
find_value
id
tenv
)
None
)
ids
let
let_decl
(
tenv
,
cenv
,
codes
)
p
e
=
let
(
tenv
,
decl
,
_
)
=
Typer
.
type_let_decl
tenv
p
e
in
let
let_decl
~
run
~
show
(
tenv
,
cenv
,
codes
)
p
e
=
let
(
tenv
,
decl
,
ids
)
=
Typer
.
type_let_decl
tenv
p
e
in
let
(
cenv
,
code
)
=
compile_let_decl
cenv
decl
in
(
tenv
,
cenv
,
code
::
codes
)
run_show
~
run
~
show
tenv
cenv
code
ids
;
(
tenv
,
cenv
,
code
::
codes
)
let
let_funs
(
tenv
,
cenv
,
codes
)
funs
=
let
(
tenv
,
funs
,
_
)
=
Typer
.
type_let_funs
tenv
funs
in
let
let_funs
~
run
~
show
(
tenv
,
cenv
,
codes
)
funs
=
let
(
tenv
,
funs
,
ids
)
=
Typer
.
type_let_funs
tenv
funs
in
let
(
cenv
,
code
)
=
compile_rec_funs
cenv
funs
in
(
tenv
,
cenv
,
code
::
codes
)
run_show
~
run
~
show
tenv
cenv
code
ids
;
(
tenv
,
cenv
,
code
::
codes
)
let
type_defs
(
tenv
,
cenv
,
codes
)
typs
=
let
tenv
=
Typer
.
enter_types
(
Typer
.
type_defs
tenv
typs
)
tenv
in
...
...
@@ -177,30 +204,39 @@ let rec collect_types accu = function
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
.
Using
(
x
,
cu
)
}
::
rest
->
phrases
(
using
accu
x
cu
)
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
let
rec
phrases
~
run
~
show
~
loading
~
directive
=
let
rec
loop
accu
phs
=
match
phs
with
|
{
descr
=
Ast
.
FunDecl
_
}
::
_
->
let
(
funs
,
rest
)
=
collect_funs
[]
phs
in
loop
(
let_funs
~
run
~
show
accu
funs
)
rest
|
{
descr
=
Ast
.
TypeDecl
(
_
,_
)
}
::
_
->
let
(
typs
,
rest
)
=
collect_types
[]
phs
in
loop
(
type_defs
accu
typs
)
rest
|
{
descr
=
Ast
.
SchemaDecl
(
name
,
schema
)
}
::
rest
->
Typer
.
register_schema
name
schema
;
loop
accu
rest
|
{
descr
=
Ast
.
Namespace
(
pr
,
ns
)
}
::
rest
->
loop
(
namespace
accu
pr
ns
)
rest
|
{
descr
=
Ast
.
Using
(
x
,
cu
)
}
::
rest
->
loading
cu
;
loop
(
using
accu
x
cu
)
rest
|
{
descr
=
Ast
.
EvalStatement
e
}
::
rest
->
loop
(
eval
~
run
~
show
accu
e
)
rest
|
{
descr
=
Ast
.
LetDecl
(
p
,
e
)
}
::
rest
->
loop
(
let_decl
~
run
~
show
accu
p
e
)
rest
|
{
descr
=
Ast
.
Directive
d
}
::
rest
->
let
(
tenv
,
cenv
,_
)
=
accu
in
directive
tenv
cenv
d
;
loop
accu
rest
|
[]
->
accu
in
loop
let
comp_unit
?
(
run
=
false
)
?
(
show
=
fun
_
_
_
->
()
)
?
(
loading
=
fun
_
->
()
)
?
(
directive
=
fun
_
_
_
->
()
)
tenv
cenv
phs
=
let
(
tenv
,
cenv
,
codes
)
=
phrases
~
run
~
show
~
loading
~
directive
(
tenv
,
cenv
,
[]
)
phs
in
(
tenv
,
cenv
,
List
.
rev
codes
)
compile/compile.mli
View file @
5380b16c
...
...
@@ -4,6 +4,8 @@ open Lambda
type
env
val
from_comp_unit
:
(
Types
.
CompUnit
.
t
->
env
)
ref
val
dump
:
Format
.
formatter
->
env
->
unit
val
empty
:
env
val
serialize
:
env
Serialize
.
Put
.
f
val
deserialize
:
env
Serialize
.
Get
.
f
...
...
@@ -17,6 +19,11 @@ val compile_let_decl : env -> Typed.let_decl -> env * code_item
val
compile_rec_funs
:
env
->
Typed
.
texpr
list
->
env
*
code_item
val
comp_unit
:
val
comp_unit
:
?
run
:
bool
->
?
show
:
(
id
option
->
Types
.
t
->
Value
.
t
option
->
unit
)
->
?
loading
:
(
Types
.
CompUnit
.
t
->
unit
)
->
?
directive
:
(
Typer
.
t
->
env
->
Ast
.
toplevel_directive
->
unit
)
->
Typer
.
t
->
env
->
Ast
.
pmodule_item
list
->
Typer
.
t
*
env
*
Lambda
.
code_item
list
compile/lambda.ml
View file @
5380b16c
...
...
@@ -6,6 +6,12 @@ type var_loc =
|
Global
of
int
|
Dummy
let
print_var_loc
ppf
=
function
|
Stack
i
->
Format
.
fprintf
ppf
"Stack %i"
i
|
Env
i
->
Format
.
fprintf
ppf
"Env %i"
i
|
Global
i
->
Format
.
fprintf
ppf
"Global %i"
i
|
Dummy
->
Format
.
fprintf
ppf
"Dummy"
type
schema_component_kind
=
[
`Type
|
`Element
|
`Attribute
|
`Attribute_group
|
`Model_group
]
option
...
...
driver/cduce.ml
View file @
5380b16c
...
...
@@ -17,12 +17,12 @@ let prefix filename suff =
else
filename
let
toplevel
=
ref
false
let
verbose
=
ref
false
let
typing_env
=
State
.
ref
"Cduce.typing_env"
Builtin
.
env
let
compile_env
=
State
.
ref
"Cduce.compile_env"
Compile
.
empty
let
get_global_value
v
=
let
get_global_value
cenv
v
=
Eval
.
var
(
Compile
.
find
v
!
compile_env
)
let
get_global_type
v
=
...
...
@@ -56,16 +56,16 @@ let dump_value ppf x t v =
Format
.
fprintf
ppf
"@[val %a : @[%a = %a@]@]@."
U
.
print
(
Id
.
value
x
)
print_norm
t
print_value
v
let
dump_env
ppf
=
Format
.
fprintf
ppf
"Types:%a@."
Typer
.
dump_types
!
typing_
env
;
Format
.
fprintf
ppf
"Namespace prefixes:@
\n
%a"
Typer
.
dump_ns
!
typing_
env
;
let
dump_env
ppf
tenv
cenv
=
Format
.
fprintf
ppf
"Types:%a@."
Typer
.
dump_types
t
env
;
Format
.
fprintf
ppf
"Namespace prefixes:@
\n
%a"
Typer
.
dump_ns
t
env
;
Format
.
fprintf
ppf
"Namespace prefixes used for pretty-printing:@.%t"
Ns
.
InternalPrinter
.
dump
;
Format
.
fprintf
ppf
"Schemas: %s@."
(
String
.
concat
" "
(
List
.
map
U
.
get_str
(
Typer
.
get_schema_names
()
)));
Format
.
fprintf
ppf
"Values:@."
;
Typer
.
iter_values
!
typing_
env
(
fun
x
t
->
dump_value
ppf
x
t
(
get_global_value
x
))
Typer
.
iter_values
t
env
(
fun
x
t
->
dump_value
ppf
x
t
(
get_global_value
cenv
x
))
let
directive_help
ppf
=
Format
.
fprintf
ppf
...
...
@@ -157,86 +157,47 @@ let rec print_exn ppf = function
Format
.
fprintf
ppf
"%a@."
print_protect
(
Printexc
.
to_string
exn
)
let
display
ppf
l
=
List
.
iter
(
fun
(
x
,
t
)
->
dump_value
ppf
x
t
(
get_global_value
x
))
l
let
eval_quiet
e
=
let
(
e
,_
)
=
Typer
.
type_expr
!
typing_env
e
in
let
e
=
Compile
.
compile_eval
!
compile_env
e
in
let
eval_quiet
tenv
cenv
e
=
let
(
e
,_
)
=
Typer
.
type_expr
tenv
e
in
let
e
=
Compile
.
compile_eval
cenv
e
in
Eval
.
expr
e
let
eval
ppf
e
=
let
(
e
,
t
)
=
Typer
.
type_expr
!
typing_env
e
in
Location
.
dump_loc
ppf
(
e
.
Typed
.
exp_loc
,
`Full
);
let
e
=
Compile
.
compile_eval
!
compile_env
e
in
let
v
=
Eval
.
expr
e
in
Format
.
fprintf
ppf
"- : @[@[%a@] =@ @[%a@]@]@."
print_norm
t
print_value
v
;
v
let
let_decl
ppf
p
e
=
let
(
tenv
,
decl
,
typs
)
=
Typer
.
type_let_decl
!
typing_env
p
e
in
let
(
env
,
decl
)
=
Compile
.
compile_let_decl
!
compile_env
decl
in
Eval
.
eval
decl
;
compile_env
:=
env
;
typing_env
:=
tenv
;
display
ppf
typs
let
let_funs
ppf
funs
=
let
(
tenv
,
funs
,
typs
)
=
Typer
.
type_let_funs
!
typing_env
funs
in
let
(
env
,
funs
)
=
Compile
.
compile_rec_funs
!
compile_env
funs
in
Eval
.
eval
funs
;
compile_env
:=
env
;
typing_env
:=
tenv
;
display
ppf
typs
let
debug
ppf
=
function
let
debug
ppf
tenv
cenv
=
function
|
`Subtype
(
t1
,
t2
)
->
Format
.
fprintf
ppf
"[DEBUG:subtype]@."
;
let
t1
=
Types
.
descr
(
Typer
.
typ
!
typing_
env
t1
)
and
t2
=
Types
.
descr
(
Typer
.
typ
!
typing_
env
t2
)
in
let
t1
=
Types
.
descr
(
Typer
.
typ
t
env
t1
)
and
t2
=
Types
.
descr
(
Typer
.
typ
t
env
t2
)
in
let
s
=
Types
.
subtype
t1
t2
in
Format
.
fprintf
ppf
"%a %a %a : %b@."
print_norm
t1
print_protect
"<="
print_norm
t2
s
|
`Sample
t
->
Format
.
fprintf
ppf
"[DEBUG:sample]@."
;
(
try
let
t
=
Types
.
descr
(
Typer
.
typ
!
typing_
env
t
)
in
let
t
=
Types
.
descr
(
Typer
.
typ
t
env
t
)
in
Format
.
fprintf
ppf
"%a@."
print_sample
(
Sample
.
get
t
)
with
Not_found
->
Format
.
fprintf
ppf
"Empty type : no sample !@."
)
|
`Filter
(
t
,
p
)
->
Format
.
fprintf
ppf
"[DEBUG:filter]@."
;
let
t
=
Typer
.
typ
!
typing_
env
t
and
p
=
Typer
.
pat
!
typing_
env
p
in
let
t
=
Typer
.
typ
t
env
t
and
p
=
Typer
.
pat
t
env
p
in
let
f
=
Patterns
.
filter
(
Types
.
descr
t
)
p
in
List
.
iter
(
fun
(
x
,
t
)
->
Format
.
fprintf
ppf
" %a:%a@."
U
.
print
(
Id
.
value
x
)
print_norm
(
Types
.
descr
t
))
f
|
`Accept
p
->
Format
.
fprintf
ppf
"[DEBUG:accept]@."
;
let
p
=
Typer
.
pat
!
typing_
env
p
in
let
p
=
Typer
.
pat
t
env
p
in
let
t
=
Patterns
.
accept
p
in
Format
.
fprintf
ppf
" %a@."
Types
.
Print
.
print
(
Types
.
descr
t
)
|
`Compile
(
t
,
pl
)
->
Format
.
fprintf
ppf
"[DEBUG:compile]@."
;
let
t
=
Typer
.
typ
!
typing_
env
t
and
pl
=
List
.
map
(
Typer
.
pat
!
typing_
env
)
pl
in
let
t
=
Typer
.
typ
t
env
t
and
pl
=
List
.
map
(
Typer
.
pat
t
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
let
t
=
Typer
.
typ
t
env
t
in
(
match
Explain
.
explain
(
Types
.
descr
t
)
(
eval
_quiet
tenv
cenv
e
)
with
|
Some
p
->
Format
.
fprintf
ppf
"Explanation: @[%a@]@."
Explain
.
print_path
p
...
...
@@ -244,73 +205,55 @@ let debug ppf = function
Format
.
fprintf
ppf
"Explanation: value has given type@."
)
let
rec
collect_funs
ppf
accu
=
function
|
{
descr
=
Ast
.
FunDecl
e
}
::
rest
->
collect_funs
ppf
(
e
::
accu
)
rest
|
rest
->
let_funs
ppf
accu
;
rest
let
rec
collect_types
ppf
accu
=
function
|
{
descr
=
Ast
.
TypeDecl
(
x
,
t
)
}
::
rest
->
collect_types
ppf
((
x
,
t
)
::
accu
)
rest
|
rest
->
typing_env
:=
Typer
.
enter_types
(
Typer
.
type_defs
!
typing_env
accu
)
!
typing_env
;
rest
let
flush_stdout
()
=
Format
.
fprintf
Format
.
std_formatter
"@."
let
rec
phrases
ppf
phs
=
match
phs
with
|
{
descr
=
Ast
.
FunDecl
_
}
::
_
->
phrases
ppf
(
collect_funs
ppf
[]
phs
)
|
{
descr
=
Ast
.
TypeDecl
(
_
,_
)
}
::
_
->
phrases
ppf
(
collect_types
ppf
[]
phs
)
|
{
descr
=
Ast
.
SchemaDecl
(
name
,
schema
)
}
::
rest
->
Typer
.
register_schema
name
schema
;
phrases
ppf
rest
|
{
descr
=
Ast
.
Namespace
(
pr
,
ns
)
}
::
rest
->
typing_env
:=
Typer
.
enter_ns
pr
ns
!
typing_env
;
phrases
ppf
rest
|
{
descr
=
Ast
.
Using
(
x
,
cu
)
}
::
rest
->
Librarian
.
import
cu
;
Librarian
.
run
Value
.
nil
cu
;
typing_env
:=
Typer
.
enter_cu
x
cu
!
typing_env
;
phrases
ppf
rest
|
{
descr
=
Ast
.
EvalStatement
e
}
::
rest
->
ignore
(
eval
ppf
e
);
phrases
ppf
rest
|
{
descr
=
Ast
.
LetDecl
(
p
,
e
)
}
::
rest
->
let_decl
ppf
p
e
;
phrases
ppf
rest
|
{
descr
=
Ast
.
Debug
l
}
::
rest
->
debug
ppf
l
;
phrases
ppf
rest
|
{
descr
=
Ast
.
Directive
`Quit
}
::
rest
->
if
!
toplevel
then
raise
End_of_file
;
phrases
ppf
rest
|
{
descr
=
Ast
.
Directive
`Env
}
::
rest
->
dump_env
ppf
;
phrases
ppf
rest
|
{
descr
=
Ast
.
Directive
(
`Print_schema
schema
)
}
::
rest
->
let
flush_ppf
ppf
=
Format
.
fprintf
ppf
"@."
let
directive
ppf
tenv
cenv
=
function
|
`Debug
d
->
debug
ppf
tenv
cenv
d
|
`Quit
->
(
if
!
toplevel
then
raise
End_of_file
)
|
`Env
->
dump_env
ppf
tenv
cenv
|
`Print_schema
schema
->
Schema_common
.
print_schema
ppf
(
Typer
.
get_schema
schema
);
flush_stdout
()
;
phrases
ppf
rest
|
{
descr
=
Ast
.
Directive
(
`Print_type
name
)
}
::
rest
->
Typer
.
dump_type
Format
.
std_formatter
!
typing_env
name
;
flush_stdout
()
;
phrases
ppf
rest
|
{
descr
=
Ast
.
Directive
(
`Print_schema_type
schema_ref
)
}
::
rest
->
Typer
.
dump_schema_type
Format
.
std_formatter
schema_ref
;
flush_stdout
()
;
phrases
ppf
rest
|
{
descr
=
Ast
.
Directive
`Reinit_ns
}
::
rest
->
Typer
.
set_ns_table_for_printer
!
typing_env
;
phrases
ppf
rest
|
{
descr
=
Ast
.
Directive
`Help
}
::
rest
->
directive_help
ppf
;
phrases
ppf
rest
|
{
descr
=
Ast
.
Directive
(
`Dump
pexpr
)
}
::
rest
->
Format
.
fprintf
ppf
"%a@."
Value
.
dump_xml
(
eval_quiet
pexpr
);
phrases
ppf
rest
|
[]
->
()
flush_ppf
ppf
|
`Print_type
name
->
Typer
.
dump_type
ppf
tenv
name
;
flush_ppf
ppf
|
`Print_schema_type
schema_ref
->
Typer
.
dump_schema_type
ppf
schema_ref
;
flush_ppf
ppf
|
`Reinit_ns
->
Typer
.
set_ns_table_for_printer
tenv
|
`Help
->
directive_help
ppf
|
`Dump
pexpr
->
Value
.
dump_xml
ppf
(
eval_quiet
tenv
cenv
pexpr
);
flush_ppf
ppf
let
print_id_opt
ppf
=
function
|
None
->
Format
.
fprintf
ppf
"-"
|
Some
id
->
Format
.
fprintf
ppf
"val %a"
U
.
print
(
Id
.
value
id
)
let
print_value_opt
ppf
=
function
|
None
->
()
|
Some
v
->
Format
.
fprintf
ppf
" = %a"
print_value
v
let
show
ppf
id
t
v
=
Format
.
fprintf
ppf
"@[%a : @[%a%a@]@]@."
print_id_opt
id
print_norm
t
print_value_opt
v
let
phrases
ppf
phs
=
let
(
tenv
,
cenv
,_
)
=
Compile
.
comp_unit
~
run
:
true
~
show
:
(
show
ppf
)
~
loading
:
(
fun
cu
->
Librarian
.
import
cu
;
Librarian
.
run
Value
.
nil
cu
)
~
directive
:
(
directive
ppf
)
!
typing_env
!
compile_env
phs
in
typing_env
:=
tenv
;
compile_env
:=
cenv
let
catch_exn
ppf_err
exn
=
if
not
catch_exceptions
then
raise
exn
;
...
...
@@ -344,7 +287,7 @@ let compile src out_dir =
|
Some
x
->
x
in
let
out
=
Filename
.
concat
out_dir
(
cu
^
".cdo"
)
in
let
id
=
Types
.
CompUnit
.
mk
(
U
.
mk_latin1
cu
)
in
Librarian
.
compile
id
src
;
Librarian
.
compile
!
verbose
id
src
;
Librarian
.
save
id
out
;
exit
0
with
exn
->
catch_exn
Format
.
err_formatter
exn
;
exit
1
...
...
@@ -355,7 +298,7 @@ let compile_run src argv =
then
raise
(
InvalidInputFilename
src
);
let
cu
=
Filename
.
chop_suffix
(
Filename
.
basename
src
)
".cd"
in
let
id
=
Types
.
CompUnit
.
mk
(
U
.
mk_latin1
cu
)
in
Librarian
.
compile
id
src
;
Librarian
.
compile
!
verbose
id
src
;
Librarian
.
run
argv
id
with
exn
->
catch_exn
Format
.
err_formatter
exn
;
exit
1
...
...
@@ -369,3 +312,5 @@ let run obj argv =
Librarian
.
run
argv
id
with
exn
->
catch_exn
Format
.
err_formatter
exn
;
exit
1
let
dump_env
ppf
=
dump_env
ppf
!
typing_env
!
compile_env
driver/cduce.mli
View file @
5380b16c
val
toplevel
:
bool
ref
val
verbose
:
bool
ref
val
enter_global_value
:
Ident
.
id
->
Value
.
t
->
Types
.
descr
->
unit
val
script
:
Format
.
formatter
->
Format
.
formatter
->
char
Stream
.
t
->
bool
...
...
driver/librarian.ml
View file @
5380b16c
...
...
@@ -113,7 +113,15 @@ let check_loop id =
let
depends
=
ref
[]
let
during_compile
=
ref
false
let
rec
compile
id
src
=
let
show
ppf
id
t
v
=
match
id
with
|
Some
id
->
Format
.
fprintf
ppf
"@[val %a : @[%a@]@."
U
.
print
(
Id
.
value
id
)
Types
.
Print
.
print
t
|
None
->
()
let
rec
compile
verbose
id
src
=
check_loop
id
;
protect_op
"Compile external file"
;
let
ic
=
...
...
@@ -131,14 +139,18 @@ let rec compile id src =
let
argv
=
ident
(
U
.
mk
"argv"
)
in
during_compile
:=
true
;
C
.
enter
id
;
let
cu
=
mk
(
Compile
.
comp_unit
(
Typer
.
enter_value
argv
(
Sequence
.
star
Sequence
.
string
)
Builtin
.
env
)
(
Compile
.
enter_global
Compile
.
empty
argv
)
p
)
in
let
show
=
if
verbose
then
Some
(
show
Format
.
std_formatter
)
else
None
in
let
cu
=
Compile
.
comp_unit
?
show
(
Typer
.
enter_value
argv
(
Sequence
.
star
Sequence
.
string
)
Builtin
.
env
)
(
Compile
.
enter_global
Compile
.
empty
argv
)
p
in
let
cu
=
mk
cu
in
C
.
Tbl
.
add
tbl
id
cu
;
C
.
leave
()
;
during_compile
:=
false
;
...
...
@@ -186,7 +198,14 @@ let rec run argv id =
match
cu
.
vals
with
|
None
->
List
.
iter
(
run
argv
)
cu
.
depends
;
cu
.
vals
<-
Some
(
Eval
.
comp_unit
[
argv
]
cu
.
code
)
let
vals
=
Eval
.
comp_unit
[
argv
]
cu
.
code
in
(*
Compile.dump Format.std_formatter cu.compile;
Array.iter (fun v ->
Format.fprintf Format.std_formatter "%a@."
Value.print v) vals;
*)
cu
.
vals
<-
Some
vals
|
Some
_
->
()
let
import
id
=
ignore
(
load
id
)
...
...
driver/librarian.mli
View file @
5380b16c
...
...
@@ -6,7 +6,7 @@ exception NoImplementation of Types.CompUnit.t
val
obj_path
:
string
list
ref
val
compile
:
Types
.
CompUnit
.
t
->
string
->
unit
val
compile
:
bool
->
Types
.
CompUnit
.
t
->
string
->
unit
val
run
:
Value
.
t
->
Types
.
CompUnit
.
t
->
unit
val
import
:
Types
.
CompUnit
.
t
->
unit
val
save
:
Types
.
CompUnit
.
t
->
string
->
unit
...
...
driver/run.ml
View file @
5380b16c
...
...
@@ -35,8 +35,8 @@ let specs = ref
" save persistency file after running CDuce program"
;
"--dump"
,
Arg
.
String
(
fun
s
->
save_dump
:=
Some
s
;
load_dump
:=
Some
s
)
,
" specify persistency file for loading and saving"
;
"--verbose"
,
Arg
.
Unit
(
fun
()
->
failwith
"--verbose: not yet implemented"
)
,
"verbose output
(typing, result
s)"
;
"--verbose"
,
Arg
.
Set
Cduce
.
verbose
,
"verbose output
for compilation (show types of exported value
s)"
;
"--compile"
,
Arg
.
Set
compile
,
"compile the given CDuce file"
;
"--obj-dir"
,
Arg
.
String
(
fun
s
->
out_dir
:=
s
::
!
out_dir
)
,
...
...
parser/ast.ml
View file @
5380b16c
...
...
@@ -14,7 +14,6 @@ and pmodule_item' =
|
Namespace
of
U
.
t
*
Ns
.
t
|
Using
of
U
.
t
*
Types
.
CompUnit
.
t
|
EvalStatement
of
pexpr
|
Debug
of
debug_directive
|
Directive
of
toplevel_directive
and
debug_directive
=
[
`Filter
of
ppat
*
ppat
...
...
@@ -33,6 +32,7 @@ and toplevel_directive =
|
`Print_schema
of
U
.
t
|
`Print_schema_type
of
Schema_types
.
component_kind
*
U
.
t
*
U
.
t
|
`Print_type
of
U
.
t
|
`Debug
of
debug_directive
]
...
...
parser/parser.ml
View file @
5380b16c
...
...
@@ -121,7 +121,7 @@ EXTEND
|
(
name
,
ns
)
=
namespace_binding
;
"in"
;
e2
=
expr
LEVEL
"top"
->
let
e
=
exp
loc
(
NamespaceIn
(
name
,
ns
,
e2
))
in
[
mk
loc
(
EvalStatement
(
exp
loc
e
))
]
|
"debug"
;
d
=
debug_directive
->
[
mk
loc
(
Debug
d
)
]
|
"debug"
;
d
=
debug_directive
->
[
mk
loc
(
Directive
(
`
Debug
d
)
)
]
|
DIRECTIVE
"#utf8"
->
Ulexer
.
enc
:=
Ulexing
.
Utf8
;
[
]
|
DIRECTIVE
"#latin1"
->
Ulexer
.
enc
:=
Ulexing
.
Latin1
;
[
]
|
DIRECTIVE
"#ascii"
->
Ulexer
.
enc
:=
Ulexing
.
Ascii
;
[
]
...
...
runtime/eval.ml
View file @
5380b16c
...
...
@@ -309,6 +309,16 @@ let eval = function
let
comp_unit
init
code
=
List
.
iter
push
init
;
List
.
iter
eval
code
;
let
r
=
Array
.
sub
!
stack
0
!
sp
in
sp
:=
0
;
r
(* Save the stack so as to be able to run a loaded comp_uni
from the toplevel *)
let
old_stack
=
!
stack
in
let
old_sp
=
!
sp
in
let
restore
()
=
stack
:=
old_stack
;
sp
:=
old_sp
in
stack
:=
Array
.
create
1024
Value
.
Absent
;
sp
:=
0
;
try
List
.
iter
push
init
;
List
.
iter
eval
code
;
let
r
=
Array
.
sub
!
stack
0
!
sp
in
restore
()
;
r
with
exn
->
restore
()
;
raise
exn
web/team.xml
View file @
5380b16c
...
...
@@ -23,6 +23,10 @@
Alain Frisch
</a>
(Ph.D. student)
</li>
<li>