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
4aca145e
Commit
4aca145e
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2004-05-05 23:56:31 by afrisch] Revu compilation des globals
Original author: afrisch Date: 2004-05-05 23:56:32+00:00
parent
57badc36
Changes
14
Hide whitespace changes
Inline
Side-by-side
compile/compile.ml
View file @
4aca145e
...
...
@@ -2,10 +2,14 @@ open Ident
open
Lambda
type
env
=
{
cu
:
Types
.
CompUnit
.
t
option
;
(* None: toplevel *)
vars
:
var_loc
Env
.
t
;
stack_size
:
int
stack_size
:
int
;
global_size
:
int
}
let
global_size
env
=
env
.
global_size
let
dump
ppf
env
=
Env
.
iter
(
fun
id
loc
->
...
...
@@ -13,19 +17,25 @@ let dump ppf env =
env
.
vars
let
empty
=
{
vars
=
Env
.
empty
;
stack_size
=
0
}
let
mk
cu
=
{
cu
=
cu
;
vars
=
Env
.
empty
;
stack_size
=
0
;
global_size
=
0
}
let
empty_toplevel
=
mk
None
let
empty
x
=
mk
(
Some
x
)
let
serialize
s
env
=
assert
(
env
.
stack_size
=
0
);
(
match
env
.
cu
with
|
Some
cu
->
Types
.
CompUnit
.
serialize
s
cu
|
None
->
assert
false
);
Serialize
.
Put
.
env
Id
.
serialize
Lambda
.
Put
.
var_loc
Env
.
iter
s
env
.
vars
;
Serialize
.
Put
.
int
s
env
.
stack
_size
Serialize
.
Put
.
int
s
env
.
global
_size
let
deserialize
s
=
let
cu
=
Types
.
CompUnit
.
deserialize
s
in
let
vars
=
Serialize
.
Get
.
env
Id
.
deserialize
Lambda
.
Get
.
var_loc
Env
.
add
Env
.
empty
s
in
let
size
=
Serialize
.
Get
.
int
s
in
{
vars
=
vars
;
stack_size
=
size
}
{
cu
=
Some
cu
;
vars
=
vars
;
stack_size
=
0
;
global_size
=
size
}
let
find
x
env
=
...
...
@@ -37,15 +47,14 @@ let from_comp_unit = ref (fun cu -> assert false)
let
find_ext
cu
x
=
let
env
=
!
from_comp_unit
cu
in
match
find
x
env
with
|
Ext
(
_
,_
)
as
v
->
Var
v
|
_
->
assert
false
find
x
env
let
rec
compile
env
tail
e
=
compile_aux
env
tail
e
.
Typed
.
exp_descr
and
compile_aux
env
tail
=
function
|
Typed
.
Forget
(
e
,_
)
->
compile
env
tail
e
|
Typed
.
Var
x
->
Var
(
find
x
env
)
|
Typed
.
ExtVar
(
cu
,
x
)
->
find_ext
cu
x
|
Typed
.
ExtVar
(
cu
,
x
)
->
Var
(
find_ext
cu
x
)
|
Typed
.
Apply
(
e1
,
e2
)
->
Apply
(
tail
,
compile
env
false
e1
,
compile
env
tail
e2
)
|
Typed
.
Abstraction
a
->
compile_abstr
env
a
|
Typed
.
Cst
c
->
Const
c
...
...
@@ -92,7 +101,7 @@ and compile_abstr env a =
let
slots
=
Array
.
of_list
(
List
.
rev
slots
)
in
let
env
=
{
vars
=
fun_env
;
stack_size
=
0
}
in
let
env
=
{
env
with
vars
=
fun_env
;
stack_size
=
0
}
in
let
body
=
compile_branches
env
true
a
.
Typed
.
fun_body
in
Abstraction
(
slots
,
a
.
Typed
.
fun_iface
,
body
)
...
...
@@ -112,39 +121,59 @@ and compile_branch env tail br =
let
env
=
List
.
fold_left
(
fun
env
x
->
{
vars
=
Env
.
add
x
(
Stack
env
.
stack_size
)
env
.
vars
;
stack_size
=
env
.
stack_size
+
1
}
{
env
with
vars
=
Env
.
add
x
(
Stack
env
.
stack_size
)
env
.
vars
;
stack_size
=
env
.
stack_size
+
1
}
)
env
(
Patterns
.
fv_list
br
.
Typed
.
br_pat
)
in
(
br
.
Typed
.
br_pat
,
compile
env
tail
br
.
Typed
.
br_body
)
let
enter_global
env
x
=
{
vars
=
Env
.
add
x
(
Global
env
.
stack_size
)
env
.
vars
;
stack_size
=
env
.
stack_size
+
1
}
let
enter_globals
=
List
.
fold_left
enter_global
let
compile_eval
env
e
=
Eval
(
compile
env
false
e
)
let
enter_globals
env
n
=
match
env
.
cu
with
|
None
->
let
env
=
List
.
fold_left
(
fun
env
x
->
{
env
with
vars
=
Env
.
add
x
(
Global
env
.
stack_size
)
env
.
vars
;
stack_size
=
env
.
stack_size
+
1
})
env
n
in
(
env
,
[]
)
|
Some
cu
->
List
.
fold_left
(
fun
(
env
,
code
)
x
->
let
code
=
SetGlobal
(
cu
,
env
.
global_size
)
::
code
in
let
env
=
{
env
with
vars
=
Env
.
add
x
(
Ext
(
cu
,
env
.
global_size
))
env
.
vars
;
global_size
=
env
.
global_size
+
1
}
in
(
env
,
code
)
)
(
env
,
[]
)
n
let
compile_expr
env
=
compile
env
false
let
compile_eval
env
e
=
[
Push
(
compile_expr
env
e
);
Pop
]
let
compile_let_decl
env
decl
=
let
pat
=
decl
.
Typed
.
let_pat
in
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
(
env
,
code
)
=
enter_globals
env
(
Patterns
.
fv_list
pat
)
in
(
env
,
(
Push
(
compile_expr
env
decl
.
Typed
.
let_body
))
::
(
Split
pat
)
::
code
)
let
compile_rec_funs
env
funs
=
let
fun_name
=
function
|
{
Typed
.
exp_descr
=
Typed
.
Abstraction
{
Typed
.
fun_name
=
Some
x
}}
->
x
|
_
->
assert
false
in
let
fun_a
=
function
|
{
Typed
.
exp_descr
=
Typed
.
Abstraction
a
}
->
a
let
fun_a
env
=
function
|
{
Typed
.
exp_descr
=
Typed
.
Abstraction
a
}
->
Push
(
compile_abstr
env
a
)
|
_
->
assert
false
in
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
,
Let_funs
exprs
)
let
(
env
,
code
)
=
enter_globals
env
names
in
let
exprs
=
List
.
map
(
fun_a
env
)
funs
in
(
env
,
exprs
@
code
)
(****************************************)
...
...
@@ -153,17 +182,17 @@ open Location
let
eval
~
run
~
show
(
tenv
,
cenv
,
codes
)
e
=
let
(
e
,
t
)
=
Typer
.
type_expr
tenv
e
in
let
code
=
compile_e
val
cenv
e
in
let
expr
=
compile_e
xpr
cenv
e
in
if
run
then
let
v
=
Eval
.
expr
code
in
let
v
=
Eval
.
expr
expr
in
show
None
t
(
Some
v
)
else
show
None
t
None
;
(
tenv
,
cenv
,
code
::
codes
)
(
tenv
,
cenv
,
Pop
::
Push
expr
::
codes
)
let
run_show
~
run
~
show
tenv
cenv
code
ids
=
let
run_show
~
run
~
show
tenv
cenv
code
s
ids
=
if
run
then
let
()
=
Eval
.
eval
code
in
let
()
=
Eval
.
code_items
code
s
in
List
.
iter
(
fun
(
id
,_
)
->
show
(
Some
id
)
(
Typer
.
find_value
id
tenv
)
...
...
@@ -178,13 +207,13 @@ 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
run_show
~
run
~
show
tenv
cenv
code
ids
;
(
tenv
,
cenv
,
code
::
codes
)
(
tenv
,
cenv
,
List
.
rev_append
code
codes
)
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
run_show
~
run
~
show
tenv
cenv
code
ids
;
(
tenv
,
cenv
,
code
::
codes
)
(
tenv
,
cenv
,
List
.
rev_append
code
codes
)
let
type_defs
(
tenv
,
cenv
,
codes
)
typs
=
let
tenv
=
Typer
.
enter_types
(
Typer
.
type_defs
tenv
typs
)
tenv
in
...
...
compile/compile.mli
View file @
4aca145e
...
...
@@ -2,21 +2,24 @@ open Ident
open
Lambda
type
env
val
global_size
:
env
->
int
val
from_comp_unit
:
(
Types
.
CompUnit
.
t
->
env
)
ref
val
dump
:
Format
.
formatter
->
env
->
unit
val
empty
:
env
val
empty
:
Types
.
CompUnit
.
t
->
env
val
empty_toplevel
:
env
val
serialize
:
env
Serialize
.
Put
.
f
val
deserialize
:
env
Serialize
.
Get
.
f
(*
val enter_global : env -> id -> env
val enter_globals : env -> id list -> env
*)
val
find
:
id
->
env
->
var_loc
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
compile_expr
:
env
->
Typed
.
texpr
->
Lambda
.
expr
val
comp_unit
:
...
...
@@ -25,5 +28,5 @@ val comp_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
Typer
.
t
->
env
->
Ast
.
pmodule_item
list
->
Typer
.
t
*
env
*
Lambda
.
code_item
list
compile/lambda.ml
View file @
4aca145e
...
...
@@ -3,15 +3,15 @@ open Ident
type
var_loc
=
|
Stack
of
int
|
Env
of
int
|
Global
of
int
|
Ext
of
Types
.
CompUnit
.
t
*
int
(* If pos < 0, the first arg is the value *)
|
Global
of
int
(* Only for the toplevel *)
|
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
|
Ext
(
cu
,
i
)
->
Format
.
fprintf
ppf
"Ext (_,%i)"
i
|
Global
i
->
Format
.
fprintf
ppf
"Global %i"
i
|
Dummy
->
Format
.
fprintf
ppf
"Dummy"
type
schema_component_kind
=
...
...
@@ -64,21 +64,23 @@ and dump_branches ppf brs =
List
.
iter
(
fun
(
p
,
e
)
->
Format
.
fprintf
ppf
"_ -> %a |"
dump_expr
e
)
brs
.
brs
type
code_item
=
|
Eval
of
expr
|
Let_decl
of
Patterns
.
node
*
expr
|
Let_funs
of
expr
list
|
Push
of
expr
|
Pop
|
Split
of
Patterns
.
node
|
SetGlobal
of
Types
.
CompUnit
.
t
*
int
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@."
|
Push
_
->
Format
.
fprintf
ppf
"Push@."
|
Pop
->
Format
.
fprintf
ppf
"Pop@."
|
Split
_
->
Format
.
fprintf
ppf
"Split@."
|
SetGlobal
(
_
,_
)
->
Format
.
fprintf
ppf
"SetGlobal@."
type
code
=
code_item
list
let
nbits
=
5
let
magic_compunit
=
"CDUCE:0.
2
:COMPUNIT"
let
magic_compunit
=
"CDUCE:0.
3
:COMPUNIT"
module
Put
=
struct
let
unary_op
=
ref
(
fun
_
_
->
assert
false
;
()
)
...
...
@@ -86,17 +88,10 @@ module Put = struct
open
Serialize
.
Put
let
current_cu
=
ref
Types
.
CompUnit
.
pervasives
(* Used to create self reference when saving *)
let
var_loc
s
=
function
|
Stack
i
->
bits
2
s
0
;
int
s
i
|
Global
i
->
bits
2
s
1
;
Types
.
CompUnit
.
serialize
s
!
current_cu
;
int
s
i
|
Ext
(
cu
,
i
)
->
bits
2
s
1
;
Types
.
CompUnit
.
serialize
s
cu
;
...
...
@@ -106,6 +101,7 @@ module Put = struct
int
s
i
|
Dummy
->
bits
2
s
3
|
Global
_
->
assert
false
let
rec
expr
s
=
function
|
Var
v
->
...
...
@@ -191,9 +187,10 @@ module Put = struct
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
|
Push
e
->
bits
2
s
0
;
expr
s
e
|
Pop
->
bits
2
s
1
|
Split
p
->
bits
2
s
2
;
Patterns
.
Node
.
serialize
s
p
|
SetGlobal
(
cu
,
i
)
->
bits
2
s
3
;
Types
.
CompUnit
.
serialize
s
cu
;
int
s
i
let
codes
=
list
code_item
...
...
@@ -304,13 +301,13 @@ module Get = struct
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
L
et
_decl
(
p
,
e
)
|
2
->
L
et
_funs
(
list
expr
s
)
|
0
->
Push
(
expr
s
)
|
1
->
Pop
|
2
->
Split
(
Patterns
.
Node
.
deserialize
s
)
|
3
->
l
et
cu
=
Types
.
CompUnit
.
deserialize
s
in
let
pos
=
int
s
in
S
et
Global
(
cu
,
po
s
)
|
_
->
assert
false
let
codes
=
list
code_item
...
...
driver/cduce.ml
View file @
4aca145e
...
...
@@ -22,7 +22,7 @@ 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
compile_env
=
State
.
ref
"Cduce.compile_env"
Compile
.
empty
_toplevel
let
get_global_value
cenv
v
=
Eval
.
var
(
Compile
.
find
v
!
compile_env
)
...
...
@@ -30,11 +30,6 @@ let get_global_value cenv v =
let
get_global_type
v
=
Typer
.
find_value
v
!
typing_env
let
enter_global_value
x
v
t
=
typing_env
:=
Typer
.
enter_value
x
t
!
typing_env
;
compile_env
:=
Compile
.
enter_global
!
compile_env
x
;
Eval
.
push
v
let
rec
is_abstraction
=
function
|
Ast
.
Abstraction
_
->
true
|
Ast
.
LocatedExpr
(
_
,
e
)
->
is_abstraction
e
...
...
@@ -165,7 +160,7 @@ let rec print_exn ppf = function
let
eval_quiet
tenv
cenv
e
=
let
(
e
,_
)
=
Typer
.
type_expr
tenv
e
in
let
e
=
Compile
.
compile_e
val
cenv
e
in
let
e
=
Compile
.
compile_e
xpr
cenv
e
in
Eval
.
expr
e
let
debug
ppf
tenv
cenv
=
function
...
...
@@ -255,7 +250,7 @@ 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
)
~
loading
:
Librarian
.
import
_and_run
~
directive
:
(
directive
ppf
)
!
typing_env
!
compile_env
phs
in
typing_env
:=
tenv
;
...
...
@@ -279,7 +274,6 @@ let run rule ppf ppf_err input =
try
phrases
ppf
(
parse
rule
input
);
true
with
exn
->
catch_exn
ppf_err
exn
;
false
let
script
=
run
Parser
.
prog
let
topinput
=
run
Parser
.
top_phrases
ifdef
ML_INTERFACE
then
...
...
@@ -330,24 +324,23 @@ let compile src out_dir =
exit
0
with
exn
->
catch_exn
Format
.
err_formatter
exn
;
exit
1
let
compile_run
src
argv
=
let
compile_run
src
=
try
if
not
(
Filename
.
check_suffix
src
".cd"
)
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
!
verbose
id
src
;
Librarian
.
run
argv
id
Librarian
.
run
id
with
exn
->
catch_exn
Format
.
err_formatter
exn
;
exit
1
let
run
obj
argv
=
let
run
obj
=
try
if
not
(
Filename
.
check_suffix
obj
".cdo"
)
||
(
Filename
.
basename
obj
<>
obj
)
then
raise
(
InvalidObjectFilename
obj
);
let
cu
=
Filename
.
chop_suffix
(
Filename
.
basename
obj
)
".cdo"
in
let
id
=
Types
.
CompUnit
.
mk
(
U
.
mk_latin1
cu
)
in
Librarian
.
import
id
;
Librarian
.
run
argv
id
Librarian
.
import_and_run
id
with
exn
->
catch_exn
Format
.
err_formatter
exn
;
exit
1
...
...
driver/cduce.mli
View file @
4aca145e
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
val
topinput
:
Format
.
formatter
->
Format
.
formatter
->
char
Stream
.
t
->
bool
val
dump_env
:
Format
.
formatter
->
unit
val
compile
:
string
->
string
option
->
unit
val
compile_run
:
string
->
Value
.
t
->
unit
val
run
:
string
->
Value
.
t
->
unit
val
compile_run
:
string
->
unit
val
run
:
string
->
unit
driver/librarian.ml
View file @
4aca145e
...
...
@@ -14,8 +14,9 @@ type t = {
compile
:
Compile
.
env
;
code
:
Lambda
.
code_item
list
;
mutable
digest
:
Digest
.
t
option
;
mutable
vals
:
Value
.
t
array
option
;
mutable
depends
:
C
.
t
list
vals
:
Value
.
t
array
;
mutable
depends
:
C
.
t
list
;
mutable
status
:
[
`Evaluating
|
`Unevaluated
|
`Evaluated
]
}
let
mk
(
typing
,
compile
,
code
)
=
...
...
@@ -23,11 +24,12 @@ let mk (typing,compile,code) =
compile
=
compile
;
code
=
code
;
digest
=
None
;
vals
=
None
;
vals
=
Array
.
make
(
Compile
.
global_size
compile
)
Value
.
Absent
;
depends
=
[]
;
status
=
`Unevaluated
;
}
let
magic
=
"CDUCE:compunit:0000
1
"
let
magic
=
"CDUCE:compunit:0000
2
"
let
obj_path
=
ref
[
""
]
...
...
@@ -67,7 +69,6 @@ let find_obj id =
let
save
id
out
=
protect_op
"Save compilation unit"
;
Lambda
.
Put
.
current_cu
:=
id
;
let
cu
=
find
id
in
C
.
enter
id
;
let
raw
=
Serialize
.
Put
.
run
serialize
cu
in
...
...
@@ -147,8 +148,8 @@ let rec compile verbose id src =
let
cu
=
Compile
.
comp_unit
?
show
(
Typer
.
enter_value
argv
(
Sequence
.
star
Sequence
.
string
)
Builtin
.
env
)
(
Compile
.
enter_global
Compile
.
empty
argv
)
Builtin
.
env
(
Compile
.
empty
id
)
p
in
let
cu
=
mk
cu
in
...
...
@@ -195,28 +196,40 @@ and load_check id exp =
let
cu
=
load
id
in
check_digest
id
exp
cu
.
digest
let
rec
run
argv
id
=
let
rec
run
id
=
let
cu
=
find
id
in
match
cu
.
vals
with
|
None
->
List
.
iter
(
run
argv
)
cu
.
depends
;
let
vals
=
Eval
.
comp_unit
[
argv
]
cu
.
code
in
match
cu
.
status
with
|
`Unevaluated
->
List
.
iter
run
cu
.
depends
;
cu
.
status
<-
`Evaluating
;
Eval
.
code_items
cu
.
code
;
cu
.
status
<-
`Evaluated
(*
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
_
->
()
|
`Evaluating
->
(*
failwith
("Librarian.run. Already running:" ^ (U.to_string (C.value id)))
*)
()
|
`Evaluated
->
()
let
import
id
=
ignore
(
load
id
)
let
import_and_run
id
=
import
id
;
run
id
let
()
=
Typer
.
from_comp_unit
:=
(
fun
cu
->
(
load
cu
)
.
typing
);
Compile
.
from_comp_unit
:=
(
fun
cu
->
(
load
cu
)
.
compile
);
Eval
.
from_comp_unit
:=
(
fun
cu
i
->
match
(
load
cu
)
.
vals
with
|
None
->
!
Eval
.
stack
.
(
i
)
(* TODO: check that cu is being evaluated *)
|
Some
a
->
a
.
(
i
))
Eval
.
get_global
:=
(
fun
cu
i
->
import_and_run
cu
;
(
load
cu
)
.
vals
.
(
i
));
Eval
.
set_global
:=
(
fun
cu
i
v
->
import
cu
;
let
cu
=
load
cu
in
match
cu
.
status
with
|
`Evaluating
->
cu
.
vals
.
(
i
)
<-
v
|
_
->
assert
false
);;
driver/librarian.mli
View file @
4aca145e
...
...
@@ -7,7 +7,8 @@ exception NoImplementation of Types.CompUnit.t
val
obj_path
:
string
list
ref
val
compile
:
bool
->
Types
.
CompUnit
.
t
->
string
->
unit
val
run
:
Value
.
t
->
Types
.
CompUnit
.
t
->
unit
val
run
:
Types
.
CompUnit
.
t
->
unit
val
import
:
Types
.
CompUnit
.
t
->
unit
val
import_and_run
:
Types
.
CompUnit
.
t
->
unit
val
save
:
Types
.
CompUnit
.
t
->
string
->
unit
driver/run.ml
View file @
4aca145e
...
...
@@ -169,7 +169,7 @@ let toploop () =
let
argv
args
=
Value
.
sequence
(
List
.
rev_map
Value
.
string_latin1
args
)
let
restore
argv
=
let
restore
()
=
match
!
load_dump
with
|
Some
f
->
(
try
...
...
@@ -182,8 +182,7 @@ let restore argv =
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
...
...
@@ -198,15 +197,18 @@ let save () =
let
main
()
=
match
mode
()
with
|
`Toplevel
args
->
restore
(
argv
args
);
Builtin
.
argv
:=
argv
args
;
restore
()
;
toploop
()
;
save
()
|
`Script
(
f
,
args
)
->
Cduce
.
compile_run
f
(
argv
args
)
Builtin
.
argv
:=
argv
args
;
Cduce
.
compile_run
f
|
`Compile
(
f
,
o
)
->
Cduce
.
compile
f
o
|
`Run
(
f
,
args
)
->
Cduce
.
run
f
(
argv
args
)
Builtin
.
argv
:=
argv
args
;
Cduce
.
run
f
let
()
=
(* Hum... *)
...
...
parser/parser.ml
View file @
4aca145e
...
...
@@ -271,7 +271,7 @@ EXTEND
|
IDENT
"load_xml"
|
IDENT
"load_file"
|
IDENT
"load_file_utf8"
|
IDENT
"float_of"
|
IDENT
"getenv"
|
IDENT
"getenv"
|
IDENT
"argv"
|
IDENT
"load_html"
|
IDENT
"print_xml"
|
IDENT
"print_xml_utf8"
|
IDENT
"print"
...
...
runtime/eval.ml
View file @
4aca145e
...
...
@@ -57,16 +57,22 @@ let push x =
set
stack
!
sp
x
;
incr
sp
let
from_comp_unit
=
ref
(
fun
cu
pos
->
assert
false
)
let
pop
()
=
decr
sp
;
!
stack
.
(
!
sp
)
let
get_global
=
ref
(
fun
cu
pos
->
assert
false
)
let
set_global
=
ref
(
fun
cu
pos
->
assert
false
)
let
eval_var
env
=
function
|
Env
i
->
env
.
(
i
)
|
Global
i
->
!
stack
.
(
i
)
|
Stack
i
->
!
stack
.
(
!
frame
+
i
)
|
Dummy
->
Value
.
Absent
|
Global
i
->
!
stack
.
(
i
)
|
Ext
(
cu
,
pos
)
as
x
->
if
pos
<
0
then
(
Obj
.
magic
cu
:
Value
.
t
)
else
let
v
=
!
from_comp_unit
cu
pos
in
let
v
=
!
get_global
cu
pos
in
let
x
=
Obj
.
repr
x
in