Commit 65a0a855 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2003-09-27 12:41:30 by cvscast] Serialization, new system for operators, ...

Original author: cvscast
Date: 2003-09-27 12:41:34+00:00
parent 85959868
...@@ -66,7 +66,7 @@ uninstall: ...@@ -66,7 +66,7 @@ uninstall:
# Source directories # Source directories
DIRS = misc parser schema typing types runtime driver module DIRS = misc parser schema typing types compile runtime driver module
CLEAN_DIRS = $(DIRS) tools tests CLEAN_DIRS = $(DIRS) tools tests
# Objects to build # Objects to build
...@@ -92,8 +92,11 @@ OBJECTS = \ ...@@ -92,8 +92,11 @@ OBJECTS = \
\ \
typing/typed.cmo typing/typer.cmo \ typing/typed.cmo typing/typer.cmo \
\ \
compile/lambda.cmo compile/compile.cmo \
\
runtime/load_xml.cmo runtime/run_dispatch.cmo \ runtime/load_xml.cmo runtime/run_dispatch.cmo \
runtime/print_xml.cmo runtime/eval.cmo \ runtime/print_xml.cmo runtime/eval.cmo \
compile/operators.cmo \
\ \
types/builtin.cmo driver/cduce.cmo types/builtin.cmo driver/cduce.cmo
......
open Ident
open Lambda
type env = {
vars: var_loc Env.t;
stack_size: int
}
let empty = { vars = Env.empty; stack_size = 0 }
let rec compile env e = compile_aux env e.Typed.exp_descr
and compile_aux env = function
| Typed.Forget (e,_) -> compile env e
| Typed.Var x -> Var (Env.find x env.vars)
| Typed.Apply (e1,e2) -> Apply (compile env e1, compile env e2)
| Typed.Abstraction a -> compile_abstr env a
| Typed.Cst c -> Const c
| Typed.Pair (e1,e2) -> Pair(compile env e1, compile env e2)
| Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }) ->
let env' = env in
Xml (compile env e1, compile env' e2, compile env' e3)
| Typed.Xml (_,_) -> assert false
| Typed.RecordLitt r -> Record (LabelMap.map (compile env) r)
| Typed.String (i,j,s,q) -> String (i,j,s,compile env q)
| Typed.Match (e,brs) -> Match (compile env e, compile_branches env brs)
| _ -> assert false
and compile_abstr env a =
let (slots,nb_slots,fun_env) =
List.fold_left
(fun (slots,nb_slots,fun_env) x ->
match Env.find x env.vars with
| (Stack _ | Env _) as p ->
p::slots,
succ nb_slots,
Env.add x (Env nb_slots) fun_env;
| Global _ as p ->
slots,
nb_slots,
Env.add x p fun_env
| Dummy -> assert false
)
([],0,Env.empty) (IdSet.get a.Typed.fun_fv) in
let recurs,fun_env,slots = match a.Typed.fun_name with
| Some x when IdSet.mem a.Typed.fun_fv x ->
true, Env.add x (Env 0) fun_env, Dummy::slots
| _ -> false, fun_env, slots in
let slots = Array.of_list (List.rev slots) in
let env = { vars = fun_env; stack_size = 0 } in
let body = compile_branches env a.Typed.fun_body in
Abstraction (recurs, slots, a.Typed.fun_iface, body)
and compile_branches env (brs : Typed.branches) =
{
brs = List.map (compile_branch env) brs.Typed.br_branches;
brs_input = brs.Typed.br_typ;
brs_compiled = None
}
and compile_branch env 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 (IdSet.get (Patterns.fv br.Typed.br_pat)) in
(br.Typed.br_pat, compile env br.Typed.br_body)
open Ident
type var_loc =
| Stack of int
| Env of int
| Global of int
| Dummy
type expr =
| Var of var_loc
| Apply of expr * expr
| Abstraction of bool * var_loc array * (Types.t * Types.t) list * branches
| Const of Types.Const.t
| Pair of expr * expr
| Xml of expr * expr * expr
| Record of expr label_map
| String of U.uindex * U.uindex * U.t * expr
| Match of expr * branches
| Map of expr * branches
| Transform of expr * branches
| Xtrans of expr * branches
| Validate of expr * string * string
| RemoveField of expr * label
| Dot of expr * label
| Try of expr * branches
| UnaryOp of unary_op * expr
| BinaryOp of binary_op * expr
| Ref of expr * Types.t
and unary_op = id
and binary_op = id
and branches = {
brs: (Patterns.node * expr) list;
brs_input: Types.t;
mutable brs_compiled:
(Patterns.Compile.dispatcher * expr Patterns.Compile.rhs array) option
}
(*
(* Evaluator *)
let call_stack = ref []
let env = ref [| |]
let stack = ref (Array.create 1024 Value.Absent)
let global = ref (Array.create 1024 Value.Absent)
let frame = ref 0
let sp = ref 0
let set a i x =
let n = Array.length !a in
if i = n then (
let b = Array.create (n*2) Value.Absent in
Array.blit !a 0 b 0 n;
a := b
);
!a.(i) <- x
let eval_var env = function
| Env i -> env.(i)
| Global i -> !global.(i)
| Stack i -> !stack.(!frame + i)
| Dummy -> Value.Absent
let rec eval env = function
| Var x -> eval_var env x
| Apply (e1,e2) -> eval_apply (eval env e1) (eval env e2)
| Abstraction (recurs,slots,iface,body) ->
if recurs then
let local_env = Array.map (eval_var env) slots in
let a = Value.Abstraction (local_env,iface,body) in
local_env.(Array.length local_env - 1) <- a;
a
else
let local_env = Array.map eval_var slots in
Value.Abstraction (local_env,iface,body)
and eval_apply f arg =
match f with
| Value.Abstraction (local_env,_,body) -> eval_branches local_env body arg
| _ -> assert false
*)
open Location
type type_fun = Types.t -> bool -> Types.t
module Unary = struct
module Op = struct
type t = (loc -> type_fun -> type_fun) * (Value.t -> Value.t)
end
module Proxy = Custom.Proxy(Custom.String)(Typer)(Op)
include Pool.NoHash(Proxy)
let register name make typ run ser deser =
Proxy.register name make
{ Proxy.content = (fun x -> (typ x, run x));
Proxy.serialize = ser;
Proxy.deserialize = deser };;
Typer.mk_unary_op := (fun name env -> mk (Proxy.instantiate name env));;
Typer.typ_unary_op := (fun i -> fst (Proxy.content (value i)));;
Eval.eval_unary_op := (fun i -> snd (Proxy.content (value i)));;
end
module Binary = struct
module Op = struct
type t = (loc -> type_fun -> type_fun -> type_fun) *
(Value.t -> Value.t -> Value.t)
end
module Proxy = Custom.Proxy(Custom.String)(Typer)(Op)
include Pool.NoHash(Proxy)
let register name make typ run ser deser =
Proxy.register name make
{ Proxy.content = (fun x -> (typ x, run x));
Proxy.serialize = ser;
Proxy.deserialize = deser };;
Typer.mk_binary_op := (fun name env -> mk (Proxy.instantiate name env));;
Typer.typ_binary_op := (fun i -> fst (Proxy.content (value i)));;
Eval.eval_binary_op := (fun i -> snd (Proxy.content (value i)));;
end
open Location
type type_fun = Types.t -> bool -> Types.t
module Unary: sig
include Custom.T with type t = int
val register:
string ->
(Typer.t -> 'a) ->
('a -> loc -> type_fun -> type_fun) ->
('a -> Value.t -> Value.t) ->
('a Serialize.Put.f) ->
('a Serialize.Get.f) -> unit
end
module Binary: sig
include Custom.T with type t = int
val register:
string ->
(Typer.t -> 'a) ->
('a -> loc -> type_fun -> type_fun -> type_fun) ->
('a -> Value.t -> Value.t -> Value.t) ->
('a Serialize.Put.f) ->
('a Serialize.Get.f) -> unit
end
...@@ -6,16 +6,20 @@ misc/custom.cmo: misc/q_symbol.cmo misc/serialize.cmi ...@@ -6,16 +6,20 @@ misc/custom.cmo: misc/q_symbol.cmo misc/serialize.cmi
misc/custom.cmx: misc/q_symbol.cmo misc/serialize.cmx misc/custom.cmx: misc/q_symbol.cmo misc/serialize.cmx
misc/state.cmo: misc/q_symbol.cmo misc/state.cmi misc/state.cmo: misc/q_symbol.cmo misc/state.cmi
misc/state.cmx: misc/q_symbol.cmo misc/state.cmi misc/state.cmx: misc/q_symbol.cmo misc/state.cmi
misc/pool.cmo: misc/q_symbol.cmo misc/custom.cmo misc/state.cmi misc/pool.cmi misc/pool.cmo: misc/q_symbol.cmo misc/custom.cmo misc/serialize.cmi misc/state.cmi \
misc/pool.cmx: misc/q_symbol.cmo misc/custom.cmx misc/state.cmx misc/pool.cmi misc/pool.cmi
misc/encodings.cmo: misc/q_symbol.cmo misc/encodings.cmi misc/pool.cmx: misc/q_symbol.cmo misc/custom.cmx misc/serialize.cmx misc/state.cmx \
misc/encodings.cmx: misc/q_symbol.cmo misc/encodings.cmi misc/pool.cmi
misc/encodings.cmo: misc/q_symbol.cmo misc/custom.cmo misc/serialize.cmi misc/encodings.cmi
misc/encodings.cmx: misc/q_symbol.cmo misc/custom.cmx misc/serialize.cmx misc/encodings.cmi
misc/bool.cmo: misc/q_symbol.cmo misc/custom.cmo misc/serialize.cmi misc/bool.cmi misc/bool.cmo: misc/q_symbol.cmo misc/custom.cmo misc/serialize.cmi misc/bool.cmi
misc/bool.cmx: misc/q_symbol.cmo misc/custom.cmx misc/serialize.cmx misc/bool.cmi misc/bool.cmx: misc/q_symbol.cmo misc/custom.cmx misc/serialize.cmx misc/bool.cmi
misc/pretty.cmo: misc/q_symbol.cmo misc/pretty.cmi misc/pretty.cmo: misc/q_symbol.cmo misc/pretty.cmi
misc/pretty.cmx: misc/q_symbol.cmo misc/pretty.cmi misc/pretty.cmx: misc/q_symbol.cmo misc/pretty.cmi
misc/ns.cmo: misc/q_symbol.cmo misc/encodings.cmi misc/pool.cmi misc/state.cmi misc/ns.cmi misc/ns.cmo: misc/q_symbol.cmo misc/custom.cmo misc/encodings.cmi misc/pool.cmi \
misc/ns.cmx: misc/q_symbol.cmo misc/encodings.cmx misc/pool.cmx misc/state.cmx misc/ns.cmi misc/serialize.cmi misc/state.cmi misc/ns.cmi
misc/ns.cmx: misc/q_symbol.cmo misc/custom.cmx misc/encodings.cmx misc/pool.cmx \
misc/serialize.cmx misc/state.cmx misc/ns.cmi
types/sortedList.cmo: misc/q_symbol.cmo misc/custom.cmo misc/serialize.cmi types/sortedList.cmi types/sortedList.cmo: misc/q_symbol.cmo misc/custom.cmo misc/serialize.cmi types/sortedList.cmi
types/sortedList.cmx: misc/q_symbol.cmo misc/custom.cmx misc/serialize.cmx types/sortedList.cmi types/sortedList.cmx: misc/q_symbol.cmo misc/custom.cmx misc/serialize.cmx types/sortedList.cmi
types/boolean.cmo: misc/q_symbol.cmo misc/custom.cmo types/sortedList.cmi types/boolean.cmi types/boolean.cmo: misc/q_symbol.cmo misc/custom.cmo types/sortedList.cmi types/boolean.cmi
...@@ -37,17 +41,17 @@ types/normal.cmx: misc/q_symbol.cmo types/normal.cmi ...@@ -37,17 +41,17 @@ types/normal.cmx: misc/q_symbol.cmo types/normal.cmi
types/types.cmo: misc/q_symbol.cmo types/atoms.cmi misc/bool.cmi types/chars.cmi \ types/types.cmo: misc/q_symbol.cmo types/atoms.cmi misc/bool.cmi types/chars.cmi \
misc/custom.cmo misc/encodings.cmi types/ident.cmo types/intervals.cmi \ misc/custom.cmo misc/encodings.cmi types/ident.cmo types/intervals.cmi \
types/normal.cmi misc/ns.cmi misc/pretty.cmi misc/serialize.cmi \ types/normal.cmi misc/ns.cmi misc/pretty.cmi misc/serialize.cmi \
types/sortedList.cmi misc/state.cmi types/types.cmi types/sortedList.cmi misc/state.cmi misc/stats.cmi types/types.cmi
types/types.cmx: misc/q_symbol.cmo types/atoms.cmx misc/bool.cmx types/chars.cmx \ types/types.cmx: misc/q_symbol.cmo types/atoms.cmx misc/bool.cmx types/chars.cmx \
misc/custom.cmx misc/encodings.cmx types/ident.cmx types/intervals.cmx \ misc/custom.cmx misc/encodings.cmx types/ident.cmx types/intervals.cmx \
types/normal.cmx misc/ns.cmx misc/pretty.cmx misc/serialize.cmx \ types/normal.cmx misc/ns.cmx misc/pretty.cmx misc/serialize.cmx \
types/sortedList.cmx misc/state.cmx types/types.cmi types/sortedList.cmx misc/state.cmx misc/stats.cmx types/types.cmi
types/patterns.cmo: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi misc/custom.cmo \ types/patterns.cmo: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi misc/custom.cmo \
types/ident.cmo types/sortedList.cmi misc/state.cmi types/types.cmi \ types/ident.cmo misc/serialize.cmi types/sortedList.cmi misc/state.cmi \
types/patterns.cmi types/types.cmi types/patterns.cmi
types/patterns.cmx: misc/q_symbol.cmo types/atoms.cmx types/chars.cmx misc/custom.cmx \ types/patterns.cmx: misc/q_symbol.cmo types/atoms.cmx types/chars.cmx misc/custom.cmx \
types/ident.cmx types/sortedList.cmx misc/state.cmx types/types.cmx \ types/ident.cmx misc/serialize.cmx types/sortedList.cmx misc/state.cmx \
types/patterns.cmi types/types.cmx types/patterns.cmi
types/sequence.cmo: misc/q_symbol.cmo types/atoms.cmi types/types.cmi types/sequence.cmi types/sequence.cmo: misc/q_symbol.cmo types/atoms.cmi types/types.cmi types/sequence.cmi
types/sequence.cmx: misc/q_symbol.cmo types/atoms.cmx types/types.cmx types/sequence.cmi types/sequence.cmx: misc/q_symbol.cmo types/atoms.cmx types/types.cmx types/sequence.cmi
types/sample.cmo: misc/q_symbol.cmo types/ident.cmo types/types.cmi types/sample.cmi types/sample.cmo: misc/q_symbol.cmo types/ident.cmo types/types.cmi types/sample.cmi
...@@ -59,11 +63,11 @@ types/builtin_defs.cmx: misc/q_symbol.cmo types/atoms.cmx types/chars.cmx types/ ...@@ -59,11 +63,11 @@ types/builtin_defs.cmx: misc/q_symbol.cmo types/atoms.cmx types/chars.cmx types/
types/intervals.cmx misc/ns.cmx types/sequence.cmx types/types.cmx \ types/intervals.cmx misc/ns.cmx types/sequence.cmx types/types.cmx \
types/builtin_defs.cmi types/builtin_defs.cmi
runtime/value.cmo: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi misc/encodings.cmi \ runtime/value.cmo: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi misc/encodings.cmi \
types/ident.cmo types/intervals.cmi misc/ns.cmi types/sequence.cmi \ types/ident.cmo types/intervals.cmi compile/lambda.cmo misc/ns.cmi \
types/types.cmi runtime/value.cmi types/sequence.cmi types/types.cmi runtime/value.cmi
runtime/value.cmx: misc/q_symbol.cmo types/atoms.cmx types/chars.cmx misc/encodings.cmx \ runtime/value.cmx: misc/q_symbol.cmo types/atoms.cmx types/chars.cmx misc/encodings.cmx \
types/ident.cmx types/intervals.cmx misc/ns.cmx types/sequence.cmx \ types/ident.cmx types/intervals.cmx compile/lambda.cmx misc/ns.cmx \
types/types.cmx runtime/value.cmi types/sequence.cmx types/types.cmx runtime/value.cmi
schema/schema_types.cmo: misc/q_symbol.cmo runtime/value.cmi schema/schema_types.cmi schema/schema_types.cmo: misc/q_symbol.cmo runtime/value.cmi schema/schema_types.cmi
schema/schema_types.cmx: misc/q_symbol.cmo runtime/value.cmx schema/schema_types.cmi schema/schema_types.cmx: misc/q_symbol.cmo runtime/value.cmx schema/schema_types.cmi
schema/schema_xml.cmo: misc/q_symbol.cmo types/atoms.cmi misc/encodings.cmi misc/ns.cmi \ schema/schema_xml.cmo: misc/q_symbol.cmo types/atoms.cmi misc/encodings.cmi misc/ns.cmi \
...@@ -107,19 +111,25 @@ parser/parser.cmx: misc/q_symbol.cmo parser/ast.cmx types/atoms.cmx types/chars. ...@@ -107,19 +111,25 @@ parser/parser.cmx: misc/q_symbol.cmo parser/ast.cmx types/atoms.cmx types/chars.
schema/schema_xml.cmx types/sequence.cmx types/types.cmx \ schema/schema_xml.cmx types/sequence.cmx types/types.cmx \
parser/ulexer.cmx parser/parser.cmi parser/ulexer.cmx parser/parser.cmi
typing/typed.cmo: misc/q_symbol.cmo types/ident.cmo parser/location.cmi types/patterns.cmi \ typing/typed.cmo: misc/q_symbol.cmo types/ident.cmo parser/location.cmi types/patterns.cmi \
types/types.cmi runtime/value.cmi types/types.cmi
typing/typed.cmx: misc/q_symbol.cmo types/ident.cmx parser/location.cmx types/patterns.cmx \ typing/typed.cmx: misc/q_symbol.cmo types/ident.cmx parser/location.cmx types/patterns.cmx \
types/types.cmx runtime/value.cmx types/types.cmx
typing/typer.cmo: misc/q_symbol.cmo parser/ast.cmo types/atoms.cmi types/builtin_defs.cmi \ typing/typer.cmo: misc/q_symbol.cmo parser/ast.cmo types/atoms.cmi types/builtin_defs.cmi \
types/chars.cmi types/ident.cmo parser/location.cmi misc/ns.cmi \ types/chars.cmi misc/custom.cmo types/ident.cmo parser/location.cmi \
types/patterns.cmi schema/schema_builtin.cmi schema/schema_types.cmi \ misc/ns.cmi types/patterns.cmi schema/schema_builtin.cmi \
schema/schema_validator.cmi types/sequence.cmi misc/state.cmi \ schema/schema_types.cmi schema/schema_validator.cmi types/sequence.cmi \
typing/typed.cmo types/types.cmi typing/typer.cmi misc/serialize.cmi misc/state.cmi misc/stats.cmi typing/typed.cmo \
types/types.cmi typing/typer.cmi
typing/typer.cmx: misc/q_symbol.cmo parser/ast.cmx types/atoms.cmx types/builtin_defs.cmx \ typing/typer.cmx: misc/q_symbol.cmo parser/ast.cmx types/atoms.cmx types/builtin_defs.cmx \
types/chars.cmx types/ident.cmx parser/location.cmx misc/ns.cmx \ types/chars.cmx misc/custom.cmx types/ident.cmx parser/location.cmx \
types/patterns.cmx schema/schema_builtin.cmx schema/schema_types.cmx \ misc/ns.cmx types/patterns.cmx schema/schema_builtin.cmx \
schema/schema_validator.cmx types/sequence.cmx misc/state.cmx \ schema/schema_types.cmx schema/schema_validator.cmx types/sequence.cmx \
typing/typed.cmx types/types.cmx typing/typer.cmi misc/serialize.cmx misc/state.cmx misc/stats.cmx typing/typed.cmx \
types/types.cmx typing/typer.cmi
compile/lambda.cmo: misc/q_symbol.cmo types/ident.cmo types/patterns.cmi types/types.cmi
compile/lambda.cmx: misc/q_symbol.cmo types/ident.cmx types/patterns.cmx types/types.cmx
compile/compile.cmo: misc/q_symbol.cmo types/patterns.cmi typing/typed.cmo
compile/compile.cmx: misc/q_symbol.cmo types/patterns.cmx typing/typed.cmx
runtime/load_xml.cmo: misc/q_symbol.cmo types/atoms.cmi misc/encodings.cmi types/ident.cmo \ runtime/load_xml.cmo: misc/q_symbol.cmo types/atoms.cmi misc/encodings.cmi types/ident.cmo \
parser/location.cmi misc/ns.cmi runtime/value.cmi runtime/load_xml.cmi parser/location.cmi misc/ns.cmi runtime/value.cmi runtime/load_xml.cmi
runtime/load_xml.cmx: misc/q_symbol.cmo types/atoms.cmx misc/encodings.cmx types/ident.cmx \ runtime/load_xml.cmx: misc/q_symbol.cmo types/atoms.cmx misc/encodings.cmx types/ident.cmx \
...@@ -142,38 +152,47 @@ runtime/eval.cmx: misc/q_symbol.cmo types/builtin_defs.cmx types/ident.cmx types ...@@ -142,38 +152,47 @@ runtime/eval.cmx: misc/q_symbol.cmo types/builtin_defs.cmx types/ident.cmx types
runtime/run_dispatch.cmx schema/schema_validator.cmx \ runtime/run_dispatch.cmx schema/schema_validator.cmx \
schema/schema_xml.cmx types/sequence.cmx typing/typed.cmx \ schema/schema_xml.cmx types/sequence.cmx typing/typed.cmx \
typing/typer.cmx types/types.cmx runtime/value.cmx runtime/eval.cmi typing/typer.cmx types/types.cmx runtime/value.cmx runtime/eval.cmi
types/builtin.cmo: misc/q_symbol.cmo parser/ast.cmo types/atoms.cmi types/builtin_defs.cmi \ compile/operators.cmo: misc/q_symbol.cmo misc/custom.cmo runtime/eval.cmi parser/location.cmi \
types/chars.cmi types/ident.cmo types/intervals.cmi runtime/load_xml.cmi \ misc/pool.cmi typing/typer.cmi types/types.cmi runtime/value.cmi \
parser/location.cmi misc/ns.cmi runtime/print_xml.cmo types/sequence.cmi \ compile/operators.cmi
typing/typed.cmo typing/typer.cmi types/types.cmi runtime/value.cmi \ compile/operators.cmx: misc/q_symbol.cmo misc/custom.cmx runtime/eval.cmx parser/location.cmx \
types/builtin.cmi misc/pool.cmx typing/typer.cmx types/types.cmx runtime/value.cmx \
types/builtin.cmx: misc/q_symbol.cmo parser/ast.cmx types/atoms.cmx types/builtin_defs.cmx \ compile/operators.cmi
types/chars.cmx types/ident.cmx types/intervals.cmx runtime/load_xml.cmx \ types/builtin.cmo: misc/q_symbol.cmo types/atoms.cmi types/builtin_defs.cmi types/chars.cmi \
parser/location.cmx misc/ns.cmx runtime/print_xml.cmx types/sequence.cmx \ types/ident.cmo types/intervals.cmi runtime/load_xml.cmi \
typing/typed.cmx typing/typer.cmx types/types.cmx runtime/value.cmx \ parser/location.cmi misc/ns.cmi compile/operators.cmi \
types/builtin.cmi runtime/print_xml.cmo types/sequence.cmi typing/typer.cmi types/types.cmi \
driver/cduce.cmo: misc/q_symbol.cmo parser/ast.cmo runtime/eval.cmi types/ident.cmo \ runtime/value.cmi types/builtin.cmi
parser/location.cmi misc/ns.cmi parser/parser.cmi types/patterns.cmi \ types/builtin.cmx: misc/q_symbol.cmo types/atoms.cmx types/builtin_defs.cmx types/chars.cmx \
types/sample.cmi misc/state.cmi typing/typed.cmo typing/typer.cmi \ types/ident.cmx types/intervals.cmx runtime/load_xml.cmx \
types/types.cmi parser/ulexer.cmi runtime/value.cmi driver/cduce.cmi parser/location.cmx misc/ns.cmx compile/operators.cmx \
driver/cduce.cmx: misc/q_symbol.cmo parser/ast.cmx runtime/eval.cmx types/ident.cmx \ runtime/print_xml.cmx types/sequence.cmx typing/typer.cmx types/types.cmx \
parser/location.cmx misc/ns.cmx parser/parser.cmx types/patterns.cmx \ runtime/value.cmx types/builtin.cmi
types/sample.cmx misc/state.cmx typing/typed.cmx typing/typer.cmx \ driver/cduce.cmo: misc/q_symbol.cmo parser/ast.cmo types/builtin.cmi runtime/eval.cmi \
types/types.cmx parser/ulexer.cmx runtime/value.cmx driver/cduce.cmi types/ident.cmo parser/location.cmi misc/ns.cmi parser/parser.cmi \
types/patterns.cmi types/sample.cmi misc/state.cmi typing/typed.cmo \
typing/typer.cmi types/types.cmi parser/ulexer.cmi runtime/value.cmi \
driver/cduce.cmi
driver/cduce.cmx: misc/q_symbol.cmo parser/ast.cmx types/builtin.cmx runtime/eval.cmx \
types/ident.cmx parser/location.cmx misc/ns.cmx parser/parser.cmx \
types/patterns.cmx types/sample.cmx misc/state.cmx typing/typed.cmx \
typing/typer.cmx types/types.cmx parser/ulexer.cmx runtime/value.cmx \
driver/cduce.cmi
driver/run.cmo: misc/q_symbol.cmo driver/cduce.cmi types/ident.cmo runtime/load_xml.cmi \ driver/run.cmo: misc/q_symbol.cmo driver/cduce.cmi types/ident.cmo runtime/load_xml.cmi \
parser/location.cmi types/sequence.cmi misc/state.cmi parser/ulexer.cmi \ parser/location.cmi types/sequence.cmi misc/serialize.cmi misc/state.cmi \
runtime/value.cmi misc/stats.cmi parser/ulexer.cmi runtime/value.cmi
driver/run.cmx: misc/q_symbol.cmo driver/cduce.cmx types/ident.cmx runtime/load_xml.cmx \ driver/run.cmx: misc/q_symbol.cmo driver/cduce.cmx types/ident.cmx runtime/load_xml.cmx \
parser/location.cmx types/sequence.cmx misc/state.cmx parser/ulexer.cmx \ parser/location.cmx types/sequence.cmx misc/serialize.cmx misc/state.cmx \
runtime/value.cmx misc/stats.cmx parser/ulexer.cmx runtime/value.cmx
driver/webiface.cmo: misc/q_symbol.cmo driver/cduce.cmi driver/examples.cmo parser/location.cmi \ driver/webiface.cmo: misc/q_symbol.cmo driver/cduce.cmi driver/examples.cmo parser/location.cmi \
misc/state.cmi misc/state.cmi
driver/webiface.cmx: misc/q_symbol.cmo driver/cduce.cmx driver/examples.cmx parser/location.cmx \ driver/webiface.cmx: misc/q_symbol.cmo driver/cduce.cmx driver/examples.cmx parser/location.cmx \
misc/state.cmx misc/state.cmx
misc/pool.cmi: misc/q_symbol.cmo misc/custom.cmo misc/pool.cmi: misc/q_symbol.cmo misc/custom.cmo
misc/encodings.cmi: misc/q_symbol.cmo misc/custom.cmo misc/serialize.cmi
misc/bool.cmi: misc/q_symbol.cmo misc/custom.cmo misc/bool.cmi: misc/q_symbol.cmo misc/custom.cmo
misc/ns.cmi: misc/q_symbol.cmo misc/custom.cmo misc/encodings.cmi misc/ns.cmi: misc/q_symbol.cmo misc/custom.cmo misc/encodings.cmi misc/serialize.cmi
types/sortedList.cmi: misc/q_symbol.cmo misc/custom.cmo types/sortedList.cmi: misc/q_symbol.cmo misc/custom.cmo misc/serialize.cmi
types/boolean.cmi: misc/q_symbol.cmo misc/custom.cmo types/boolean.cmi: misc/q_symbol.cmo misc/custom.cmo
types/intervals.cmi: misc/q_symbol.cmo misc/custom.cmo types/intervals.cmi: misc/q_symbol.cmo misc/custom.cmo
types/chars.cmi: misc/q_symbol.cmo misc/custom.cmo types/chars.cmi: misc/q_symbol.cmo misc/custom.cmo
...@@ -186,17 +205,22 @@ types/sequence.cmi: misc/q_symbol.cmo types/atoms.cmi types/types.cmi ...@@ -186,17 +205,22 @@ types/sequence.cmi: misc/q_symbol.cmo types/atoms.cmi types/types.cmi
types/sample.cmi: misc/q_symbol.cmo types/types.cmi types/sample.cmi: misc/q_symbol.cmo types/types.cmi
types/builtin_defs.cmi: misc/q_symbol.cmo types/atoms.cmi types/ident.cmo types/types.cmi types/builtin_defs.cmi: misc/q_symbol.cmo types/atoms.cmi types/ident.cmo types/types.cmi
runtime/value.cmi: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi misc/encodings.cmi \ runtime/value.cmi: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi misc/encodings.cmi \
types/ident.cmo types/intervals.cmi types/types.cmi types/ident.cmo types/intervals.cmi compile/lambda.cmo types/types.cmi
schema/schema_types.cmi: misc/q_symbol.cmo runtime/value.cmi schema/schema_types.cmi: misc/q_symbol.cmo runtime/value.cmi
schema/schema_xml.cmi: misc/q_symbol.cmo runtime/value.cmi schema/schema_xml.cmi: misc/q_symbol.cmo runtime/value.cmi
schema/schema_builtin.cmi: misc/q_symbol.cmo types/types.cmi runtime/value.cmi schema/schema_builtin.cmi: misc/q_symbol.cmo types/types.cmi runtime/value.cmi
schema/schema_validator.cmi: misc/q_symbol.cmo schema/schema_types.cmi runtime/value.cmi schema/schema_validator.cmi: misc/q_symbol.cmo schema/schema_types.cmi runtime/value.cmi
schema/schema_parser.cmi: misc/q_symbol.cmo schema/schema_types.cmi schema/schema_xml.cmi schema/schema_parser.cmi: misc/q_symbol.cmo schema/schema_types.cmi schema/schema_xml.cmi
parser/parser.cmi: misc/q_symbol.cmo parser/ast.cmo parser/parser.cmi: misc/q_symbol.cmo parser/ast.cmo
typing/typer.cmi: misc/q_symbol.cmo parser/ast.cmo types/ident.cmo parser/location.cmi \ typing/typer.cmi: misc/q_symbol.cmo parser/ast.cmo misc/custom.cmo types/ident.cmo \
misc/ns.cmi schema/schema_types.cmi schema/schema_validator.cmi \ parser/location.cmi misc/ns.cmi types/patterns.cmi \
typing/typed.cmo types/types.cmi schema/schema_types.cmi schema/schema_validator.cmi typing/typed.cmo \
types/types.cmi
runtime/load_xml.cmi: misc/q_symbol.cmo runtime/value.cmi runtime/load_xml.cmi: misc/q_symbol.cmo runtime/value.cmi
runtime/run_dispatch.cmi: misc/q_symbol.cmo types/patterns.cmi runtime/value.cmi runtime/run_dispatch.cmi: misc/q_symbol.cmo types/patterns.cmi runtime/value.cmi
runtime/eval.cmi: misc/q_symbol.cmo types/ident.cmo typing/typed.cmo runtime/value.cmi runtime/eval.cmi: misc/q_symbol.cmo types/ident.cmo typing/typed.cmo runtime/value.cmi
driver/cduce.cmi: misc/q_symbol.cmo types/ident.cmo types/types.cmi runtime/value.cmi compile/operators.cmi: misc/q_symbol.cmo misc/custom.cmo parser/location.cmi misc/serialize.cmi \
typing/typer.cmi types/types.cmi runtime/value.cmi
types/builtin.cmi: misc/q_symbol.cmo typing/typer.cmi
driver/cduce.cmi: misc/q_symbol.cmo types/ident.cmo misc/serialize.cmi types/types.cmi \
runtime/value.cmi
...@@ -35,7 +35,7 @@ let dump_env ppf = ...@@ -35,7 +35,7 @@ let dump_env ppf =
Format.fprintf ppf "Namespace prefixes:@\n%a" Typer.dump_ns !typing_env; Format.fprintf ppf "Namespace prefixes:@\n%a" Typer.dump_ns !typing_env;
Format.fprintf ppf "Namespace prefixes used for pretty-printing:@.%t" Format.fprintf ppf "Namespace prefixes used for pretty-printing:@.%t"
Ns.InternalPrinter.dump; Ns.InternalPrinter.dump;
Format.fprintf ppf "Values:@\n"; Format.fprintf ppf "Values:@.";
Env.iter Env.iter
(fun x v -> (fun x v ->
let t = Typer.find_value x !typing_env in let t = Typer.find_value x !typing_env in
...@@ -226,3 +226,9 @@ let run rule ppf ppf_err input = ...@@ -226,3 +226,9 @@ let run rule ppf ppf_err input =
let script = run Parser.prog let script = run Parser.prog
let topinput = run Parser.top_phrases let topinput = run Parser.top_phrases
let serialize_typing_env t () =
Typer.serialize t !typing_env
let deserialize_typing_env t =
typing_env := Typer.deserialize t
...@@ -6,3 +6,6 @@ val script : Format.formatter -> Format.formatter -> char Stream.t -> bool ...@@ -6,3 +6,6 @@ val script : Format.formatter -> Format.formatter -> char Stream.t -> bool
val topinput : 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 dump_env : Format.formatter -> unit
val serialize_typing_env : Serialize.Put.t -> unit -> unit
val deserialize_typing_env : Serialize.Get.t -> unit
...@@ -143,6 +143,7 @@ let main () = ...@@ -143,6 +143,7 @@ let main () =
let chan = open_in_bin f in let chan = open_in_bin f in
let s = Marshal.from_channel chan in let s = Marshal.from_channel chan in
close_in chan; close_in chan;
(* Serialize.Get.run Cduce.deserialize_typing_env s; *)
State.set s; State.set s;
Format.fprintf ppf "done ...@." Format.fprintf ppf "done ...@."
with Sys_error _ -> with Sys_error _ ->
...@@ -159,6 +160,7 @@ let main () = ...@@ -159,6 +160,7 @@ let main () =
(match !save_dump with (match !save_dump with
| Some f -> | Some f ->
Format.fprintf ppf "Saving state ...@\n"; Format.fprintf ppf "Saving state ...@\n";
(* let s = Serialize.Put.run Cduce.serialize_typing_env () in *)
let s = State.get () in let s = State.get () in
let chan = open_out_bin f in let chan = open_out_bin f in
Marshal.to_channel chan s [ Marshal.Closures ]; Marshal.to_channel chan s [ Marshal.Closures ];
......
...@@ -117,3 +117,66 @@ module Pair(X : T)(Y : T) = struct ...@@ -117,3 +117,66 @@ module Pair(X : T)(Y : T) = struct
let serialize t x = Serialize.Put.pair X.serialize Y.serialize t x let serialize t x = Serialize.Put.pair X.serialize Y.serialize t x
let deserialize t = Serialize.Get.pair X.deserialize Y.deserialize t let deserialize t = Serialize.Get.pair X.deserialize Y.deserialize t
end end
module type Proxy = sig
include T
type key
type content
type arg
type 'a spec = {
content: 'a -> content;
serialize: 'a Serialize.Put.f;
deserialize: 'a Serialize.Get.f;
}
val register: key -> (arg -> 'a) -> 'a spec -> unit
val instantiate: key -> arg -> t
val content: t -> content
end
module Proxy(Key : T)(Arg : sig type t end)(Content : sig type t end) :
Proxy with type key = Key.t and type arg = Arg.t and type content = Content.t =
struct
type key = Key.t
type arg = Arg.t
type content = Content.t
type 'a spec = {
content: 'a -> Content.t;
serialize: 'a Serialize.Put.f;
deserialize: 'a Serialize.Get.f;
}
type t = {
value: content;
put: Serialize.Put.t -> unit;
}
include Dummy
module T = Hashtbl.Make(Key)
let table = T.create 23
let register name make spec =
let f r = {
value = spec.content r;
put = (fun s -> Key.serialize s name; spec.serialize s r)