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
bd023c58
Commit
bd023c58
authored
Jul 10, 2007
by
Pietro Abate
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[r2003-12-13 13:51:19 by afrisch] Factorization + --verbose
Original author: afrisch Date: 2003-12-13 13:51:20+00:00
parent
7eb1a95d
Changes
13
Hide whitespace changes
Inline
Side-by-side
Showing
13 changed files
with
215 additions
and
188 deletions
+215
-188
Makefile.distrib
Makefile.distrib
+1
-1
compile/compile.ml
compile/compile.ml
+72
-36
compile/compile.mli
compile/compile.mli
+8
-1
compile/lambda.ml
compile/lambda.ml
+6
-0
driver/cduce.ml
driver/cduce.ml
+73
-128
driver/cduce.mli
driver/cduce.mli
+1
-0
driver/librarian.ml
driver/librarian.ml
+29
-10
driver/librarian.mli
driver/librarian.mli
+1
-1
driver/run.ml
driver/run.ml
+2
-2
parser/ast.ml
parser/ast.ml
+1
-1
parser/parser.ml
parser/parser.ml
+1
-1
runtime/eval.ml
runtime/eval.ml
+13
-3
web/team.xml
web/team.xml
+7
-4
No files found.
Makefile.distrib
View file @
bd023c58
...
...
@@ -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 @
bd023c58
...
...
@@ -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 @
bd023c58
...
...
@@ -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 @
bd023c58
...
...
@@ -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 @
bd023c58
...
...
@@ -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 @
bd023c58
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 @
bd023c58
...
...
@@ -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 @
bd023c58
...
...
@@ -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 @
bd023c58
...
...
@@ -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 @
bd023c58
...
...
@@ -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 @
bd023c58
...
...
@@ -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
(
D
ebug
d
)
]
|
"debug"
;
d
=
debug_directive
->
[
mk
loc
(
D
irective
(
`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 @
bd023c58
...
...
@@ -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 @
bd023c58
...
...
@@ -23,6 +23,10 @@
Alain Frisch
</a>
(Ph.D. student)
</li>
<li>
<a
href=
"http://www.lri.fr/~miachon/"
>
Cdric Miachon
</a>
(Ph.D. student)
</li>
<li>
<a
href=
"http://bononia.it/zack"
>
Stefano Zacchiroli
...
...
@@ -33,6 +37,9 @@
Josh de Letaillade
</a>
(DEA student)
</li>
<li>
Julien Demouth (intern).
</li>
</ul>
</box>
...
...
@@ -49,10 +56,6 @@
Marwan Burelle
</a>
(Ph.D student)
</li>
<li>
<a
href=
"http://www.lri.fr/~miachon/"
>
Cdric Miachon
</a>
(DEA student)
</li>
</ul>
</box>
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment