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
35bfd56a
Commit
35bfd56a
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2002-11-10 02:21:45 by cvscast] Saving/restoring global state
Original author: cvscast Date: 2002-11-10 02:21:46+00:00
parent
dee7d523
Changes
11
Hide whitespace changes
Inline
Side-by-side
Makefile
View file @
35bfd56a
...
...
@@ -5,7 +5,7 @@ CLEAN_DIRS = $(DIRS) tools tests
# Objects to build
MISC
=
misc/pool.cmo misc/encodings.cmo
MISC
=
misc/pool.cmo misc/encodings.cmo
misc/state.cmo
PARSER
=
parser/lexer.cmo parser/location.cmo
\
parser/wlexer.cmo
\
...
...
depend
View file @
35bfd56a
...
...
@@ -2,6 +2,8 @@ misc/encodings.cmo: misc/encodings.cmi
misc/encodings.cmx: misc/encodings.cmi
misc/pool.cmo: misc/pool.cmi
misc/pool.cmx: misc/pool.cmi
misc/state.cmo: misc/state.cmi
misc/state.cmx: misc/state.cmi
parser/ast.cmo: parser/location.cmi types/patterns.cmi types/types.cmi
parser/ast.cmx: parser/location.cmx types/patterns.cmx types/types.cmx
parser/location.cmo: parser/location.cmi
...
...
@@ -20,10 +22,12 @@ typing/typed.cmx: parser/location.cmx types/patterns.cmx types/sortedMap.cmx \
types/types.cmx
typing/typer.cmo: parser/ast.cmo types/builtin.cmo types/intervals.cmi \
parser/location.cmi types/patterns.cmi types/sequence.cmi \
types/sortedList.cmi typing/typed.cmo types/types.cmi typing/typer.cmi
types/sortedList.cmi misc/state.cmi typing/typed.cmo types/types.cmi \
typing/typer.cmi
typing/typer.cmx: parser/ast.cmx types/builtin.cmx types/intervals.cmx \
parser/location.cmx types/patterns.cmx types/sequence.cmx \
types/sortedList.cmx typing/typed.cmx types/types.cmx typing/typer.cmi
types/sortedList.cmx misc/state.cmx typing/typed.cmx types/types.cmx \
typing/typer.cmi
types/atoms.cmo: types/sortedList.cmi types/atoms.cmi
types/atoms.cmx: types/sortedList.cmx types/atoms.cmi
types/boolean.cmo: types/recursive.cmo types/sortedList.cmi types/boolean.cmi
...
...
@@ -36,14 +40,14 @@ types/chars.cmo: types/chars.cmi
types/chars.cmx: types/chars.cmi
types/intervals.cmo: types/intervals.cmi
types/intervals.cmx: types/intervals.cmi
types/patterns.cmo: types/sortedList.cmi types/sortedMap.cmi
types/types
.cmi \
types/patterns.cmi
types/patterns.cmx: types/sortedList.cmx types/sortedMap.cmx
types/types
.cmx \
types/patterns.cmi
types/recursive_noshare.cmo: types/recursive.cmo
types/recursive_noshare.cmx: types/recursive.cmx
types/recursive_share.cmo: types/recursive.cmo
types/recursive_share.cmx: types/recursive.cmx
types/patterns.cmo: types/sortedList.cmi types/sortedMap.cmi
misc/state
.cmi \
types/types.cmi
types/patterns.cmi
types/patterns.cmx: types/sortedList.cmx types/sortedMap.cmx
misc/state
.cmx \
types/types.cmx
types/patterns.cmi
types/recursive_noshare.cmo: types/recursive.cmo
misc/state.cmi
types/recursive_noshare.cmx: types/recursive.cmx
misc/state.cmx
types/recursive_share.cmo: types/recursive.cmo
misc/state.cmi
types/recursive_share.cmx: types/recursive.cmx
misc/state.cmx
types/sequence.cmo: types/atoms.cmi types/types.cmi types/sequence.cmi
types/sequence.cmx: types/atoms.cmx types/types.cmx types/sequence.cmi
types/sortedList.cmo: types/sortedList.cmi
...
...
@@ -55,11 +59,11 @@ types/type_bool.cmx: types/boolean.cmx types/recursive.cmx
types/types.cmo: types/atoms.cmi types/boolean.cmi types/chars.cmi \
types/intervals.cmi misc/pool.cmi types/recursive.cmo \
types/recursive_noshare.cmo types/sortedList.cmi types/sortedMap.cmi \
types/types.cmi
misc/state.cmi
types/types.cmi
types/types.cmx: types/atoms.cmx types/boolean.cmx types/chars.cmx \
types/intervals.cmx misc/pool.cmx types/recursive.cmx \
types/recursive_noshare.cmx types/sortedList.cmx types/sortedMap.cmx \
types/types.cmi
misc/state.cmx
types/types.cmi
runtime/eval.cmo: runtime/load_xml.cmi runtime/print_xml.cmo \
runtime/run_dispatch.cmi typing/typed.cmo types/types.cmi \
runtime/value.cmi runtime/eval.cmi
...
...
@@ -83,15 +87,15 @@ runtime/value.cmo: types/chars.cmi types/sequence.cmi types/sortedMap.cmi \
runtime/value.cmx: types/chars.cmx types/sequence.cmx types/sortedMap.cmx \
types/types.cmx runtime/value.cmi
driver/cduce.cmo: parser/ast.cmo types/builtin.cmo runtime/eval.cmi \
parser/location.cmi parser/parser.cmi types/patterns.cmi
typing/typed
.cm
o
\
typing/typer.cmi types/types.cmi runtime/value.cmi
parser/wlexer.cmo
\
driver/cduce.cmi
parser/location.cmi parser/parser.cmi types/patterns.cmi
misc/state
.cm
i
\
typing/typed.cmo
typing/typer.cmi types/types.cmi runtime/value.cmi \
parser/wlexer.cmo
driver/cduce.cmi
driver/cduce.cmx: parser/ast.cmx types/builtin.cmx runtime/eval.cmx \
parser/location.cmx parser/parser.cmx types/patterns.cmx
typing/typed
.cmx \
typing/typer.cmx types/types.cmx runtime/value.cmx
parser/wlexer.cmx
\
driver/cduce.cmi
driver/run.cmo: driver/cduce.cmi parser/location.cmi
driver/run.cmx: driver/cduce.cmx parser/location.cmx
parser/location.cmx parser/parser.cmx types/patterns.cmx
misc/state
.cmx \
typing/typed.cmx
typing/typer.cmx types/types.cmx runtime/value.cmx \
parser/wlexer.cmx
driver/cduce.cmi
driver/run.cmo: driver/cduce.cmi parser/location.cmi
misc/state.cmi
driver/run.cmx: driver/cduce.cmx parser/location.cmx
misc/state.cmx
driver/webiface.cmo: driver/cduce.cmi runtime/load_xml.cmi \
parser/location.cmi
driver/webiface.cmx: driver/cduce.cmx runtime/load_xml.cmx \
...
...
driver/cduce.ml
View file @
35bfd56a
...
...
@@ -133,10 +133,12 @@ let mk_builtin () =
(
fun
(
n
,
t
)
->
Typer
.
register_global_types
[
n
,
mk
noloc
(
Ast
.
Internal
t
)])
Builtin
.
types
let
()
=
mk_builtin
()
let
typing_env
=
State
.
ref
"Cduce.typing_env"
Typer
.
Env
.
empty
let
eval_env
=
State
.
ref
"Cduce.eval_env"
Eval
.
Env
.
empty
let
run
ppf
input
=
let
typing_env
=
ref
Typer
.
Env
.
empty
in
let
eval_env
=
ref
Eval
.
Env
.
empty
in
let
insert_type_bindings
=
List
.
iter
(
fun
(
x
,
t
)
->
typing_env
:=
Typer
.
Env
.
add
x
t
!
typing_env
;
...
...
@@ -181,7 +183,6 @@ let run ppf input =
List
.
iter
eval_decl
decls
in
try
mk_builtin
()
;
let
p
=
try
Parser
.
prog
input
with
...
...
@@ -198,10 +199,11 @@ let run ppf input =
)
([]
,
[]
)
p
in
Typer
.
register_global_types
type_decls
;
do_fun_decls
fun_decls
;
List
.
iter
phrase
p
List
.
iter
phrase
p
;
true
with
|
(
Failure
_
|
Not_found
|
Invalid_argument
_
)
as
e
->
raise
e
(* To get ocamlrun stack trace *)
|
exn
->
print_exn
ppf
exn
|
exn
->
print_exn
ppf
exn
;
false
driver/cduce.mli
View file @
35bfd56a
val
print_exn
:
Format
.
formatter
->
exn
->
unit
val
run
:
Format
.
formatter
->
char
Stream
.
t
->
unit
val
run
:
Format
.
formatter
->
char
Stream
.
t
->
bool
(* Returns true if everything is ok (no error) *)
driver/run.ml
View file @
35bfd56a
let
input_channel
=
match
Array
.
length
Sys
.
argv
with
|
1
->
Location
.
set_source
`Stream
;
stdin
|
2
->
let
fn
=
Sys
.
argv
.
(
1
)
in
Location
.
set_source
(
`File
fn
);
open_in
fn
|
_
->
Printf
.
eprintf
"Usage: cduce [script]
\n
"
;
exit
2
in
let
input
=
Stream
.
of_channel
input_channel
and
ppf
=
Format
.
std_formatter
in
Cduce
.
run
ppf
input
let
()
=
State
.
close
()
;;
let
dump
=
ref
None
let
src
=
ref
[]
let
specs
=
[
"-dump"
,
Arg
.
String
(
fun
s
->
dump
:=
Some
s
)
,
" specify filename for persistency"
]
let
()
=
Arg
.
parse
specs
(
fun
s
->
src
:=
s
::
!
src
)
"cduce [options] [script]
\n\n
Options:"
let
ppf
=
Format
.
std_formatter
let
do_file
s
=
let
(
src
,
chan
)
=
if
s
=
""
then
(
`Stream
,
stdin
)
else
(
`File
s
,
open_in
s
)
in
Location
.
set_source
src
;
let
input
=
Stream
.
of_channel
chan
in
let
ok
=
Cduce
.
run
ppf
input
in
if
s
<>
""
then
close_in
chan
;
if
not
ok
then
exit
1
let
main
()
=
(
match
!
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
;
State
.
set
s
;
Format
.
fprintf
ppf
"done ...@."
with
Sys_error
_
->
Format
.
fprintf
ppf
"failed ...@."
)
|
None
->
()
);
(
match
!
src
with
|
[]
->
Format
.
fprintf
ppf
"No script specified; using stdin ...@."
;
do_file
""
|
l
->
List
.
iter
do_file
l
);
(
match
!
dump
with
|
Some
f
->
Format
.
fprintf
ppf
"Saving state ...@
\n
"
;
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
()
runtime/eval.ml
View file @
35bfd56a
...
...
@@ -4,7 +4,7 @@ open Run_dispatch
module
Env
=
Map
.
Make
(
struct
type
t
=
string
let
compare
=
compare
end
)
type
env
=
t
Env
.
t
let
global_env
=
ref
Env
.
empty
let
global_env
=
State
.
ref
"Eval.global_env"
Env
.
empty
let
enter_global
x
v
=
global_env
:=
Env
.
add
x
v
!
global_env
...
...
types/patterns.ml
View file @
35bfd56a
...
...
@@ -27,11 +27,11 @@ and node = {
fv
:
fv
}
and
descr
=
Types
.
descr
*
fv
*
d
let
make
=
let
counter
=
ref
0
in
fun
fv
->
incr
counter
;
{
id
=
!
counter
;
descr
=
None
;
accept
=
Types
.
make
()
;
fv
=
fv
}
let
counter
=
State
.
ref
"Patterns.counter"
0
let
make
fv
=
incr
counter
;
{
id
=
!
counter
;
descr
=
None
;
accept
=
Types
.
make
()
;
fv
=
fv
}
let
define
x
((
accept
,
fv
,_
)
as
d
)
=
assert
(
x
.
fv
=
fv
);
...
...
@@ -483,7 +483,8 @@ struct
`TailCall
disp
|
x
->
x
let
cur_id
=
ref
0
let
cur_id
=
State
.
ref
"Patterns.cur_id"
0
(* TODO: save dispatchers ? *)
module
DispMap
=
Map
.
Make
(
struct
...
...
@@ -730,8 +731,10 @@ struct
|
(
res
,
catch
,
`Label
(
l1
,
_
,
ab
))
when
l1
=
l
->
(
res
,
catch
,
ab
)
|
x
->
x
)
(*
let memo_dispatch_record = ref []
let memo_dr_count = ref 0
*)
let
rec
print_normal_record
ppf
=
function
|
`Success
->
Format
.
fprintf
ppf
"Success"
...
...
@@ -770,7 +773,7 @@ struct
let
pl0
=
Array
.
map
prep
disp
.
pl
in
let
t
=
Types
.
Record
.
get
disp
.
t
in
let
r
=
dispatch_record_opt
disp
t
pl0
in
memo_dispatch_record
:=
[]
;
(*
memo_dispatch_record := [];
*)
r
and
dispatch_record_opt
disp
t
pl
=
if
Types
.
Record
.
is_empty
t
then
None
...
...
types/recursive_noshare.ml
View file @
35bfd56a
...
...
@@ -13,7 +13,7 @@ struct
let
id
n
=
n
.
id
let
counter
=
ref
0
let
counter
=
State
.
ref
"Recursive_noshare"
0
let
make
()
=
incr
counter
;
...
...
types/recursive_share.ml
View file @
35bfd56a
(* $Id: recursive_share.ml,v 1.
2
2002/1
0/31 17:35:39
cvscast Exp $ *)
(* $Id: recursive_share.ml,v 1.
3
2002/1
1/10 02:21:46
cvscast Exp $ *)
open
Recursive
module
Make
(
X
:
S
)
=
...
...
@@ -64,7 +64,9 @@ struct
let
id
n
=
!
n
.
id
let
counter
=
ref
0
let
counter
=
State
.
ref
"Recursive_share"
0
(* TODO: need to save the Hashtbl ... *)
let
make
()
=
incr
counter
;
...
...
types/types.ml
View file @
35bfd56a
...
...
@@ -167,8 +167,9 @@ struct
|
Atom
a
->
print_atom
ppf
a
|
Char
c
->
Chars
.
Unichar
.
print
ppf
c
let
named
=
DescrHash
.
create
10
let
register_global
name
d
=
DescrHash
.
add
named
d
name
let
named
=
State
.
ref
"Types.Printf.named"
DescrMap
.
empty
let
register_global
name
d
=
named
:=
DescrMap
.
add
d
name
!
named
let
marks
=
DescrHash
.
create
63
let
wh
=
ref
[]
...
...
@@ -189,7 +190,7 @@ struct
let
rec
mark
n
=
mark_descr
(
descr
n
)
and
mark_descr
d
=
if
not
(
Descr
Hash
.
mem
named
d
)
then
if
not
(
Descr
Map
.
mem
d
!
named
)
then
try
let
r
=
DescrHash
.
find
marks
d
in
if
(
!
r
=
None
)
&&
(
worth_abbrev
d
)
then
...
...
@@ -212,7 +213,7 @@ struct
let
rec
print
ppf
n
=
print_descr
ppf
(
descr
n
)
and
print_descr
ppf
d
=
try
let
name
=
Descr
Hash
.
find
named
d
in
let
name
=
Descr
Map
.
find
d
!
named
in
Format
.
fprintf
ppf
"%s"
name
with
Not_found
->
try
...
...
typing/typer.ml
View file @
35bfd56a
...
...
@@ -301,7 +301,7 @@ and pat_node s : Patterns.node =
Patterns
.
define
x
t
;
x
let
global_types
=
ref
StringMap
.
empty
let
global_types
=
State
.
ref
"Typer.global_types"
StringMap
.
empty
let
mk_typ
e
=
if
fv
e
=
[]
then
type_node
e
...
...
@@ -318,12 +318,16 @@ let pat e =
let
register_global_types
b
=
let
env
=
compile_many
!
global_types
b
in
List
.
iter
(
fun
(
v
,_
)
->
let
d
=
Types
.
descr
(
mk_typ
(
StringMap
.
find
v
env
))
in
let
t
=
StringMap
.
find
v
env
in
if
StringMap
.
mem
v
!
global_types
then
raise
(
Location
.
Generic
(
"Multiple definition for type "
^
v
));
global_types
:=
StringMap
.
add
v
t
!
global_types
;
let
d
=
Types
.
descr
(
mk_typ
t
)
in
(* let d = Types.normalize d in*)
Types
.
Print
.
register_global
v
d
;
()
)
b
;
global_types
:=
env
)
b
(* II. Build skeleton *)
...
...
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