Commit bb3efc53 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 9cf7af52
......@@ -66,7 +66,7 @@ uninstall:
# 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
# Objects to build
......@@ -92,8 +92,11 @@ OBJECTS = \
\
typing/typed.cmo typing/typer.cmo \
\
compile/lambda.cmo compile/compile.cmo \
\
runtime/load_xml.cmo runtime/run_dispatch.cmo \
runtime/print_xml.cmo runtime/eval.cmo \
compile/operators.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
misc/custom.cmx: misc/q_symbol.cmo misc/serialize.cmx
misc/state.cmo: 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.cmx: misc/q_symbol.cmo misc/custom.cmx misc/state.cmx misc/pool.cmi
misc/encodings.cmo: misc/q_symbol.cmo misc/encodings.cmi
misc/encodings.cmx: misc/q_symbol.cmo misc/encodings.cmi
misc/pool.cmo: misc/q_symbol.cmo misc/custom.cmo misc/serialize.cmi misc/state.cmi \
misc/pool.cmi
misc/pool.cmx: misc/q_symbol.cmo misc/custom.cmx misc/serialize.cmx misc/state.cmx \
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.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.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.cmx: misc/q_symbol.cmo misc/encodings.cmx misc/pool.cmx misc/state.cmx misc/ns.cmi
misc/ns.cmo: misc/q_symbol.cmo misc/custom.cmo misc/encodings.cmi misc/pool.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.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
......@@ -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 \
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/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 \
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/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/ident.cmo types/sortedList.cmi misc/state.cmi types/types.cmi \
types/patterns.cmi
types/ident.cmo misc/serialize.cmi types/sortedList.cmi misc/state.cmi \
types/types.cmi types/patterns.cmi
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/patterns.cmi
types/ident.cmx misc/serialize.cmx types/sortedList.cmx misc/state.cmx \
types/types.cmx types/patterns.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/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/
types/intervals.cmx misc/ns.cmx types/sequence.cmx types/types.cmx \
types/builtin_defs.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/types.cmi runtime/value.cmi
types/ident.cmo types/intervals.cmi compile/lambda.cmo misc/ns.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 \
types/ident.cmx types/intervals.cmx misc/ns.cmx types/sequence.cmx \
types/types.cmx runtime/value.cmi
types/ident.cmx types/intervals.cmx compile/lambda.cmx misc/ns.cmx \
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.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 \
......@@ -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 \
parser/ulexer.cmx parser/parser.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 \
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 \
types/chars.cmi types/ident.cmo parser/location.cmi misc/ns.cmi \
types/patterns.cmi schema/schema_builtin.cmi schema/schema_types.cmi \
schema/schema_validator.cmi types/sequence.cmi misc/state.cmi \
typing/typed.cmo types/types.cmi typing/typer.cmi
types/chars.cmi misc/custom.cmo types/ident.cmo parser/location.cmi \
misc/ns.cmi types/patterns.cmi schema/schema_builtin.cmi \
schema/schema_types.cmi schema/schema_validator.cmi types/sequence.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 \
types/chars.cmx types/ident.cmx parser/location.cmx misc/ns.cmx \
types/patterns.cmx schema/schema_builtin.cmx schema/schema_types.cmx \
schema/schema_validator.cmx types/sequence.cmx misc/state.cmx \
typing/typed.cmx types/types.cmx typing/typer.cmi
types/chars.cmx misc/custom.cmx types/ident.cmx parser/location.cmx \
misc/ns.cmx types/patterns.cmx schema/schema_builtin.cmx \
schema/schema_types.cmx schema/schema_validator.cmx types/sequence.cmx \
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 \
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 \
......@@ -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 \
schema/schema_xml.cmx types/sequence.cmx typing/typed.cmx \
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 \
types/chars.cmi types/ident.cmo types/intervals.cmi runtime/load_xml.cmi \
parser/location.cmi misc/ns.cmi runtime/print_xml.cmo types/sequence.cmi \
typing/typed.cmo typing/typer.cmi types/types.cmi runtime/value.cmi \
types/builtin.cmi
types/builtin.cmx: misc/q_symbol.cmo parser/ast.cmx types/atoms.cmx types/builtin_defs.cmx \
types/chars.cmx types/ident.cmx types/intervals.cmx runtime/load_xml.cmx \
parser/location.cmx misc/ns.cmx runtime/print_xml.cmx types/sequence.cmx \
typing/typed.cmx typing/typer.cmx types/types.cmx runtime/value.cmx \
types/builtin.cmi
driver/cduce.cmo: misc/q_symbol.cmo parser/ast.cmo runtime/eval.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 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
compile/operators.cmo: misc/q_symbol.cmo misc/custom.cmo runtime/eval.cmi parser/location.cmi \
misc/pool.cmi typing/typer.cmi types/types.cmi runtime/value.cmi \
compile/operators.cmi
compile/operators.cmx: misc/q_symbol.cmo misc/custom.cmx runtime/eval.cmx parser/location.cmx \
misc/pool.cmx typing/typer.cmx types/types.cmx runtime/value.cmx \
compile/operators.cmi
types/builtin.cmo: misc/q_symbol.cmo types/atoms.cmi types/builtin_defs.cmi types/chars.cmi \
types/ident.cmo types/intervals.cmi runtime/load_xml.cmi \
parser/location.cmi misc/ns.cmi compile/operators.cmi \
runtime/print_xml.cmo types/sequence.cmi typing/typer.cmi types/types.cmi \
runtime/value.cmi types/builtin.cmi
types/builtin.cmx: misc/q_symbol.cmo types/atoms.cmx types/builtin_defs.cmx types/chars.cmx \
types/ident.cmx types/intervals.cmx runtime/load_xml.cmx \
parser/location.cmx misc/ns.cmx compile/operators.cmx \
runtime/print_xml.cmx types/sequence.cmx typing/typer.cmx types/types.cmx \
runtime/value.cmx types/builtin.cmi
driver/cduce.cmo: misc/q_symbol.cmo parser/ast.cmo types/builtin.cmi runtime/eval.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 \
parser/location.cmi types/sequence.cmi misc/state.cmi parser/ulexer.cmi \
runtime/value.cmi
parser/location.cmi types/sequence.cmi misc/serialize.cmi misc/state.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 \
parser/location.cmx types/sequence.cmx misc/state.cmx parser/ulexer.cmx \
runtime/value.cmx
parser/location.cmx types/sequence.cmx misc/serialize.cmx misc/state.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 \
misc/state.cmi
driver/webiface.cmx: misc/q_symbol.cmo driver/cduce.cmx driver/examples.cmx parser/location.cmx \
misc/state.cmx
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/ns.cmi: misc/q_symbol.cmo misc/custom.cmo misc/encodings.cmi
types/sortedList.cmi: misc/q_symbol.cmo misc/custom.cmo
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 misc/serialize.cmi
types/boolean.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
......@@ -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/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 \
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_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_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
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 \
misc/ns.cmi schema/schema_types.cmi schema/schema_validator.cmi \
typing/typed.cmo types/types.cmi
typing/typer.cmi: misc/q_symbol.cmo parser/ast.cmo misc/custom.cmo types/ident.cmo \
parser/location.cmi misc/ns.cmi types/patterns.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/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
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 =
Format.fprintf ppf "Namespace prefixes:@\n%a" Typer.dump_ns !typing_env;
Format.fprintf ppf "Namespace prefixes used for pretty-printing:@.%t"
Ns.InternalPrinter.dump;
Format.fprintf ppf "Values:@\n";
Format.fprintf ppf "Values:@.";
Env.iter
(fun x v ->
let t = Typer.find_value x !typing_env in
......@@ -226,3 +226,9 @@ let run rule ppf ppf_err input =
let script = run Parser.prog
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
val topinput : Format.formatter -> Format.formatter -> char Stream.t -> bool
val dump_env : Format.formatter -> unit
val serialize_typing_env : Serialize.Put.t -> unit -> unit
val deserialize_typing_env : Serialize.Get.t -> unit
......@@ -143,7 +143,8 @@ let main () =
let chan = open_in_bin f in
let s = Marshal.from_channel chan in
close_in chan;
State.set s;
(* Serialize.Get.run Cduce.deserialize_typing_env s; *)
State.set s;
Format.fprintf ppf "done ...@."
with Sys_error _ ->
Format.fprintf ppf "failed ...@.")
......@@ -159,6 +160,7 @@ let main () =
(match !save_dump with
| Some f ->
Format.fprintf ppf "Saving state ...@\n";
(* let s = Serialize.Put.run Cduce.serialize_typing_env () in *)
let s = State.get () in
let chan = open_out_bin f in
Marshal.to_channel chan s [ Marshal.Closures ];
......
......@@ -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 deserialize t = Serialize.Get.pair X.deserialize Y.deserialize t
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)
} in
let deserialize s = f (spec.deserialize s) in
T.add table name
((fun arg -> f (make arg)),
(fun s -> f (spec.deserialize s)))
let content x = x.value
let instantiate name (arg : Arg.t) =
fst (T.find table name) arg
let serialize s x =
x.put s
let deserialize s =
let name = Key.deserialize s in
snd (T.find table name) s
end
......@@ -2,13 +2,9 @@ type uchar = int
module Utf8 =
struct
type t = string
include Custom.String
type uindex = int
let hash = Hashtbl.hash
let equal (x : t) y = x = y
let compare (x : t) y = compare x y
(* TODO: handle UTF-8 viewport *)
let to_string s =
......@@ -73,7 +69,11 @@ struct
check s (i+4) j
| _ -> false
let check s = check s 0 (String.length s)
let is_valid s = check s 0 (String.length s)
let check s = assert (is_valid s)
let mk_check s =
if is_valid s then Some (mk s) else None
let get s i =
match s.[i] with
......@@ -180,4 +180,7 @@ struct
s.[3] <- Char.chr (0x80 lor (p land 0x3f));
s
let serialize_sub t s i j =
Serialize.Put.substring t s i (j - i)
end
......@@ -2,15 +2,10 @@ type uchar = int
module Utf8 :
sig
type t
include Custom.T
type uindex
val hash: t -> int
val equal: t -> t -> bool
val compare: t -> t -> int
val check: string -> bool