Commit 35bfd56a authored by Pietro Abate's avatar Pietro Abate

[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
......@@ -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 \
......
......@@ -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.cmo \
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.cmi \
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 \
......
......@@ -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
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) *)
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\nOptions:"
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 ()
......@@ -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
......
......@@ -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
......
......@@ -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;
......
(* $Id: recursive_share.ml,v 1.2 2002/10/31 17:35:39 cvscast Exp $ *)
(* $Id: recursive_share.ml,v 1.3 2002/11/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;
......
......@@ -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 (DescrHash.mem named d) then
if not (DescrMap.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 = DescrHash.find named d in
let name = DescrMap.find d !named in
Format.fprintf ppf "%s" name
with Not_found ->
try
......
......@@ -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 *)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment