Commit c979b48b authored by Pietro Abate's avatar Pietro Abate

[r2003-10-08 21:24:38 by cvscast] Separate compilation

Original author: cvscast
Date: 2003-10-08 21:25:22+00:00
parent 352961ec
......@@ -66,7 +66,7 @@ uninstall:
# Source directories
DIRS = misc parser schema typing types compile runtime driver module
DIRS = misc parser schema typing types compile runtime driver
CLEAN_DIRS = $(DIRS) tools tests
# Objects to build
......@@ -75,7 +75,7 @@ OBJECTS = \
misc/stats.cmo \
misc/serialize.cmo misc/custom.cmo \
misc/state.cmo misc/pool.cmo misc/encodings.cmo misc/bool.cmo \
misc/pretty.cmo misc/ns.cmo \
misc/pretty.cmo misc/ns.cmo misc/inttbl.cmo \
\
types/sortedList.cmo types/boolean.cmo types/ident.cmo \
types/intervals.cmo types/chars.cmo types/atoms.cmo \
......@@ -100,7 +100,7 @@ OBJECTS = \
compile/compile.cmo \
compile/operators.cmo \
\
types/builtin.cmo driver/cduce.cmo
types/builtin.cmo driver/librarian.cmo driver/cduce.cmo
CDUCE = $(OBJECTS) driver/run.cmo
WEBIFACE = $(OBJECTS) driver/examples.cmo driver/webiface.cmo
......@@ -173,10 +173,13 @@ driver/examples.ml: cduce web/examples/build.cd web/examples/examples.xml
(cd web/examples; ../../cduce --quiet build.cd --arg examples.xml)
webpages: cduce web/site.cdo
(cd web; ../cduce --run site.cdo --arg site.xml)
(cd web; ../cduce --run site --arg site.xml)
web/site.cdo: cduce web/site.cd
./cduce --compile web/site.cd
web/site.cdo: cduce web/xhtml.cdo web/site.cd
(cd web; ../cduce --compile site)
web/xhtml.cdo: cduce web/xhtml.cd
(cd web; ../cduce --compile xhtml)
website: webpages webiface
......
......@@ -26,10 +26,19 @@ let find x env =
with Not_found ->
failwith ("Compile: cannot find " ^ (Ident.to_string x))
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
| Global i -> ExtVar (cu,i)
| _ -> assert false
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.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
......@@ -155,6 +164,10 @@ let namespace (tenv,cenv,codes) pr ns =
let tenv = Typer.enter_ns pr ns tenv in
(tenv,cenv,codes)
let using (tenv,cenv,codes) x cu =
let tenv = Typer.enter_cu x cu tenv in
(tenv,cenv,codes)
let rec collect_funs accu = function
| { descr = Ast.FunDecl e } :: rest -> collect_funs (e::accu) rest
| rest -> (accu,rest)
......@@ -176,6 +189,8 @@ let rec phrases accu phs = match phs with
phrases accu rest
| { descr = Ast.Namespace (pr,ns) } :: rest ->
phrases (namespace accu pr ns) rest
| { descr = Ast.Using (x,cu) } :: rest ->
phrases (using accu x cu) rest
| { descr = Ast.EvalStatement e } :: rest ->
phrases (eval accu e) rest
| { descr = Ast.LetDecl (p,e) } :: rest ->
......
......@@ -2,7 +2,12 @@ open Ident
open Lambda
type env
val from_comp_unit: (Types.CompUnit.t -> env) ref
val empty : 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
......
......@@ -8,6 +8,7 @@ type var_loc =
type expr =
| Var of var_loc
| ExtVar of Types.CompUnit.t * int
| Apply of bool * expr * expr
| Abstraction of var_loc array * (Types.t * Types.t) list * branches
......@@ -150,6 +151,10 @@ module Put = struct
bits nbits s 18;
expr s e;
Types.Node.serialize s t
| ExtVar (cu,pos) ->
bits nbits s 19;
Types.CompUnit.serialize s cu;
int s pos
and branches s brs =
list (pair Patterns.Node.serialize expr) s brs.brs;
......@@ -254,6 +259,10 @@ module Get = struct
let e = expr s in
let t = Types.Node.deserialize s in
Ref (e,t)
| 19 ->
let cu = Types.CompUnit.deserialize s in
let pos = int s in
ExtVar (cu,pos)
| _ -> assert false
and branches s =
......
......@@ -20,6 +20,8 @@ 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
misc/inttbl.cmo: misc/q_symbol.cmo misc/inttbl.cmi
misc/inttbl.cmx: misc/q_symbol.cmo misc/inttbl.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
......@@ -40,12 +42,14 @@ types/normal.cmo: misc/q_symbol.cmo types/normal.cmi
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 misc/stats.cmi types/types.cmi
misc/inttbl.cmi types/normal.cmi misc/ns.cmi misc/pool.cmi \
misc/pretty.cmi misc/serialize.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 misc/stats.cmx types/types.cmi
misc/inttbl.cmx types/normal.cmx misc/ns.cmx misc/pool.cmx \
misc/pretty.cmx misc/serialize.cmx 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 misc/serialize.cmi types/sortedList.cmi misc/state.cmi \
types/types.cmi types/patterns.cmi
......@@ -159,11 +163,11 @@ runtime/eval.cmx: misc/q_symbol.cmo types/builtin_defs.cmx types/ident.cmx compi
schema/schema_xml.cmx types/sequence.cmx typing/typed.cmx \
typing/typer.cmx types/types.cmx runtime/value.cmx runtime/eval.cmi
compile/compile.cmo: misc/q_symbol.cmo parser/ast.cmo types/ident.cmo compile/lambda.cmo \
parser/location.cmi types/patterns.cmi typing/typed.cmo typing/typer.cmi \
types/types.cmi compile/compile.cmi
parser/location.cmi types/patterns.cmi misc/serialize.cmi \
typing/typed.cmo typing/typer.cmi types/types.cmi compile/compile.cmi
compile/compile.cmx: misc/q_symbol.cmo parser/ast.cmx types/ident.cmx compile/lambda.cmx \
parser/location.cmx types/patterns.cmx typing/typed.cmx typing/typer.cmx \
types/types.cmx compile/compile.cmi
parser/location.cmx types/patterns.cmx misc/serialize.cmx \
typing/typed.cmx typing/typer.cmx types/types.cmx compile/compile.cmi
compile/operators.cmo: misc/q_symbol.cmo misc/custom.cmo runtime/eval.cmi compile/lambda.cmo \
parser/location.cmi misc/pool.cmi typing/typer.cmi types/types.cmi \
runtime/value.cmi compile/operators.cmi
......@@ -180,18 +184,26 @@ types/builtin.cmx: misc/q_symbol.cmo types/atoms.cmx types/builtin_defs.cmx type
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/librarian.cmo: misc/q_symbol.cmo types/builtin.cmi compile/compile.cmi \
misc/encodings.cmi runtime/eval.cmi types/ident.cmo compile/lambda.cmo \
parser/location.cmi parser/parser.cmi types/sequence.cmi \
misc/serialize.cmi typing/typer.cmi types/types.cmi runtime/value.cmi \
driver/librarian.cmi
driver/librarian.cmx: misc/q_symbol.cmo types/builtin.cmx compile/compile.cmx \
misc/encodings.cmx runtime/eval.cmx types/ident.cmx compile/lambda.cmx \
parser/location.cmx parser/parser.cmx types/sequence.cmx \
misc/serialize.cmx typing/typer.cmx types/types.cmx runtime/value.cmx \
driver/librarian.cmi
driver/cduce.cmo: misc/q_symbol.cmo parser/ast.cmo types/builtin.cmi compile/compile.cmi \
runtime/eval.cmi runtime/explain.cmi types/ident.cmo compile/lambda.cmo \
runtime/eval.cmi runtime/explain.cmi types/ident.cmo driver/librarian.cmi \
parser/location.cmi misc/ns.cmi parser/parser.cmi types/patterns.cmi \
types/sample.cmi types/sequence.cmi misc/serialize.cmi misc/state.cmi \
typing/typed.cmo typing/typer.cmi types/types.cmi parser/ulexer.cmi \
runtime/value.cmi driver/cduce.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 compile/compile.cmx \
runtime/eval.cmx runtime/explain.cmx types/ident.cmx compile/lambda.cmx \
runtime/eval.cmx runtime/explain.cmx types/ident.cmx driver/librarian.cmx \
parser/location.cmx misc/ns.cmx parser/parser.cmx types/patterns.cmx \
types/sample.cmx types/sequence.cmx misc/serialize.cmx misc/state.cmx \
typing/typed.cmx typing/typer.cmx types/types.cmx parser/ulexer.cmx \
runtime/value.cmx driver/cduce.cmi
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 misc/stats.cmi \
parser/ulexer.cmi runtime/value.cmi
......@@ -212,7 +224,7 @@ types/intervals.cmi: misc/q_symbol.cmo misc/custom.cmo
types/chars.cmi: misc/q_symbol.cmo misc/custom.cmo
types/atoms.cmi: misc/q_symbol.cmo misc/custom.cmo misc/encodings.cmi misc/ns.cmi
types/types.cmi: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi misc/custom.cmo \
types/ident.cmo types/intervals.cmi
types/ident.cmo types/intervals.cmi misc/inttbl.cmi
types/patterns.cmi: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi misc/custom.cmo \
types/ident.cmo types/types.cmi
types/sequence.cmi: misc/q_symbol.cmo types/atoms.cmi types/types.cmi
......@@ -234,11 +246,11 @@ 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/explain.cmi: misc/q_symbol.cmo types/types.cmi runtime/value.cmi
runtime/eval.cmi: misc/q_symbol.cmo types/ident.cmo compile/lambda.cmo typing/typed.cmo \
runtime/value.cmi
types/types.cmi runtime/value.cmi
compile/compile.cmi: misc/q_symbol.cmo parser/ast.cmo types/ident.cmo compile/lambda.cmo \
typing/typed.cmo typing/typer.cmi
misc/serialize.cmi typing/typed.cmo typing/typer.cmi types/types.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
driver/librarian.cmi: misc/q_symbol.cmo types/types.cmi runtime/value.cmi
driver/cduce.cmi: misc/q_symbol.cmo types/ident.cmo types/types.cmi runtime/value.cmi
......@@ -250,6 +250,9 @@ let rec phrases ppf phs = match phs with
| { descr = Ast.Namespace (pr,ns) } :: rest ->
typing_env := Typer.enter_ns pr ns !typing_env;
phrases ppf rest
| { descr = Ast.Using (x,cu) } :: rest ->
typing_env := Typer.enter_cu x cu !typing_env;
phrases ppf rest
| { descr = Ast.EvalStatement e } :: rest ->
ignore (eval ppf e);
phrases ppf rest
......@@ -298,55 +301,25 @@ let run rule ppf ppf_err input =
let script = run Parser.prog
let topinput = run Parser.top_phrases
let comp_unit src =
try
let ic = open_in src in
Location.push_source (`File src);
let input = Stream.of_channel ic in
match parse Parser.prog input with
| Some p ->
close_in ic;
let argv = ident (U.mk "argv") in
let (tenv,cenv,codes) =
Compile.comp_unit
(Typer.enter_value argv (Sequence.star Sequence.string)
Builtin.env)
(Compile.enter_global Compile.empty argv)
p in
codes
| None -> exit 1
with exn -> catch_exn Format.err_formatter exn; exit 1
let run_code argv codes =
let compile src =
try
Eval.L.push argv;
List.iter Eval.L.eval codes
let id = Types.CompUnit.mk (U.mk_latin1 src) in
Librarian.compile id;
Librarian.save id;
exit 0
with exn -> catch_exn Format.err_formatter exn; exit 1
let compile src =
let codes = comp_unit src in
let oc = open_out ((prefix src ".cd") ^ ".cdo") in
let codes_s = Serialize.Put.run Lambda.Put.compunit codes in
output_string oc codes_s;
close_out oc;
exit 0
let compile_run src argv =
run_code argv (comp_unit src)
try
let id = Types.CompUnit.mk (U.mk_latin1 src) in
Librarian.compile id;
Librarian.run argv id
with exn -> catch_exn Format.err_formatter exn; exit 1
let run obj argv =
let ic = open_in obj in
let len = in_channel_length ic in
let codes = String.create len in
really_input ic codes 0 len;
close_in ic;
let codes = Serialize.Get.run Lambda.Get.compunit codes in
run_code argv codes
let serialize_typing_env t () =
Typer.serialize t !typing_env
try
let id = Types.CompUnit.mk (U.mk_latin1 obj) in
Librarian.import id;
Librarian.run argv id
with exn -> catch_exn Format.err_formatter exn; exit 1
let deserialize_typing_env t =
typing_env := Typer.deserialize t
......@@ -8,9 +8,6 @@ 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
val compile: string -> unit
val compile_run: string -> Value.t -> unit
val run: string -> Value.t -> unit
open Location
open Ident
module C = Types.CompUnit
type t = {
typing: Typer.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
}
let mk (typing,compile,code) =
{ typing = typing;
compile = compile;
code = code;
digest = None;
vals = None;
depends = [];
}
let magic = "CDUCE:compunit:00001"
let tbl = C.Tbl.create ()
let find id =
try C.Tbl.find tbl id
with Not_found -> assert false
let serialize s cu =
Serialize.Put.magic s magic;
Typer.serialize s cu.typing;
Compile.serialize s cu.compile;
Lambda.Put.codes s cu.code
let deserialize s =
Serialize.Get.magic s magic;
let typing = Typer.deserialize s in
let compile = Compile.deserialize s in
let code = Lambda.Get.codes s in
mk (typing,compile,code)
let serialize_dep=
Serialize.Put.list
(Serialize.Put.pair Encodings.Utf8.serialize Serialize.Put.string)
let deserialize_dep =
Serialize.Get.list
(Serialize.Get.pair Encodings.Utf8.deserialize Serialize.Get.string)
let source_filename id = Encodings.Utf8.to_string (C.value id) ^ ".cd"
let object_filename id = Encodings.Utf8.to_string (C.value id) ^ ".cdo"
let save id =
let cu = find id in
C.enter id;
let raw = Serialize.Put.run serialize cu in
let depend = C.close_serialize () in
C.leave ();
(*
print_endline "Dependencies:";
List.iter (fun x -> print_endline (object_filename x)) depend;
flush stdout;
*)
let depend =
try List.map
(fun id ->
match (C.Tbl.find tbl id).digest with
| Some d -> (C.value id, d)
| None -> assert false
) depend
with Not_found -> assert false in
let depend = Serialize.Put.run serialize_dep depend in
let digest = Digest.string raw in
let oc = open_out (object_filename id) in
output_value oc (digest,depend,raw);
close_out oc
let check_digest exp digest =
match digest with
| Some x ->
if exp <> x then failwith "Inconsistent checksum"
| None ->
assert false
let loop = C.Tbl.create ()
let check_loop id =
try
C.Tbl.find loop id;
failwith "Loop between compilation units"
with Not_found ->
C.Tbl.add loop id ()
let depends = ref []
let during_compile = ref false
let rec compile id =
check_loop id;
let src = source_filename id in
let ic = open_in src in
Location.push_source (`File src);
let input = Stream.of_channel ic in
let p =
try Parser.prog input
with
| Stdpp.Exc_located (_, (Location _ as e)) -> raise e
| Stdpp.Exc_located ((i,j), e) -> raise_loc i j e
in
close_in ic;
let argv = ident (U.mk "argv") in
during_compile := true;
C.enter id;
let cu = mk
(
Compile.comp_unit
(Typer.enter_value argv (Sequence.star Sequence.string)
Builtin.env)
(Compile.enter_global Compile.empty argv)
p
) in
C.Tbl.add tbl id cu;
C.leave ();
during_compile := false;
cu.depends <- !depends;
depends := []
let rec load id =
try
C.Tbl.find tbl id
with Not_found ->
check_loop id;
if !during_compile then depends := id :: !depends;
(* Printf.eprintf "load %s: start\n" (object_filename id);
flush stderr; *)
let ic = open_in (object_filename id) in
let (dig, depend, raw) = input_value ic in
close_in ic;
let depend = Serialize.Get.run deserialize_dep depend in
List.iter (fun (id,dig) -> load_check (C.mk id) dig) depend;
C.enter id;
let cu = Serialize.Get.run deserialize raw in
C.leave ();
cu.depends <- List.map (fun (id,_) -> C.mk id) depend;
cu.digest <- Some dig;
C.Tbl.add tbl id cu;
cu
and load_check id exp =
let cu = load id in
check_digest exp cu.digest
let rec run argv id =
let cu = find id in
List.iter (run argv) cu.depends;
Eval.L.push argv;
List.iter Eval.L.eval cu.code;
cu.vals <- Some (Eval.L.comp_unit ())
let import id = ignore (load id)
let () =
Typer.from_comp_unit := (fun cu -> (load cu).typing);
Compile.from_comp_unit := (fun cu -> (load cu).compile);
Eval.L.from_comp_unit := (fun cu i ->
match (load cu).vals with
| None -> assert false
| Some a -> a.(i))
val compile: Types.CompUnit.t -> unit
val run: Value.t -> Types.CompUnit.t -> unit
val import: Types.CompUnit.t -> unit
val save: Types.CompUnit.t -> unit
module type S = sig
type key
type 'a t
val create: unit -> 'a t
val fold: 'a t -> (key -> 'a -> 'b -> 'b) -> 'b -> 'b
val clear: 'a t -> unit
val add: 'a t -> key -> 'a -> unit
val find: 'a t -> key -> 'a
end
type key = int
type 'a t = 'a option array ref
let create () = ref (Array.create 16 None)
let clear t = t := Array.create 16 None
let fold t f x =
let rec aux i x =
if i < 0 then x
else
let x =
match !t.(i) with
| Some y -> f i y x
| None -> x
in
aux (pred i) x
in
aux (pred (Array.length !t)) x
let add t i x =
let l = Array.length !t in
if i >= l then (
let n = max (i + 1) (l * 2) in
let a = Array.create n None in
Array.blit !t 0 a 0 l;
t := a;
);
(!t).(i) <- Some x
let find t i =
if i >= Array.length !t then raise Not_found
else match (!t).(i) with
| None -> raise Not_found
| Some x -> x
module type S = sig
type key
type 'a t
val create: unit -> 'a t
val fold: 'a t -> (key -> 'a -> 'b -> 'b) -> 'b -> 'b
val clear: 'a t -> unit
val add: 'a t -> key -> 'a -> unit
val find: 'a t -> key -> 'a
end
include S with type key = int
open Encodings
val split_qname: Utf8.t -> string * Utf8.t
exception UnknownPrefix of Utf8.t
include Custom.T with type t = int (* Namespaces (URIs) *)
......
......@@ -14,6 +14,7 @@ and pmodule_item' =
| LetDecl of ppat * pexpr
| FunDecl of pexpr
| Namespace of U.t * Ns.t
| Using of U.t * Types.CompUnit.t
| EvalStatement of pexpr
| Debug of debug_directive
| Directive of toplevel_directive
......@@ -37,7 +38,7 @@ and pexpr =
| LocatedExpr of loc * pexpr
(* CDuce is a Lambda-calculus ... *)
| Var of id
| Var of U.t
| Apply of pexpr * pexpr
| Abstraction of abstr
......@@ -84,7 +85,7 @@ and branches = (ppat * pexpr) list
and ppat = ppat' located
and ppat' =
| PatVar of id
| PatVar of U.t
| SchemaVar of (* type/pattern schema variable *)
schema_item_kind * string * string
| Cst of pexpr
......
......@@ -101,6 +101,8 @@ EXTEND
| (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
[ mk loc (EvalStatement (exp loc (Match (e1,[p,e2])))) ]
| "type"; x = IDENT; "="; t = pat -> [ mk loc (TypeDecl (ident x,t)) ]
| "using"; name = IDENT; "="; cu = STRING2 ->
[ mk loc (Using (U.mk name, Types.CompUnit.mk (U.mk cu))) ]
| "schema"; name = IDENT; "="; uri = STRING2 ->
protect_op "schema";
let schema_doc = Schema_xml.pxp_tree_of uri in
......@@ -168,7 +170,7 @@ EXTEND
| "if" | "then" | "else"
| "transform" | "fun" | "in"
| "let" | "type" | "debug" | "include"
| "and" | "validate" | "schema" | "namespace" | "ref"
| "and" | "validate" | "schema" | "namespace" | "ref" | "using"
]
-> a
]
......@@ -235,7 +237,7 @@ EXTEND
let re = Star(Alt(SeqCapture(id_dummy,Elem p), Elem any)) in
let ct = mk loc (Regexp (re,any)) in
let p = mk loc (XmlT (tag, multi_prod loc [att;ct])) in
let b = (p, Var id_dummy) in
let b = (p, Var (Id.value id_dummy)) in
exp loc (Transform (e,[b]))
]
|
......@@ -290,7 +292,7 @@ EXTEND
| s = STRING2 ->
let s = U.mk s in
exp loc (String (U.start_index s, U.end_index s, s, cst_nil))
| a = IDENT -> exp loc (Var (ident a))
| a = IDENT -> exp loc (Var (U.mk a))
| "!"; e = expr ->
exp loc (Apply (Dot (e, U.mk "get"), cst_nil))
| i = INT -> exp loc (Integer (Intervals.V.mk i))
......@@ -333,7 +335,7 @@ EXTEND
let_binding: [
[ "let"; is_fun_decl; OPT "fun"; (f,a,b) = fun_decl ->
let f = match f with Some x -> x | None -> assert false in
let p = mk loc (PatVar f) in
let p = mk loc (PatVar (Id.value f)) in
let abst = { fun_name = Some f; fun_iface = a; fun_body = b } in
let e = exp loc (Abstraction abst) in
(true,p,e)
......@@ -467,7 +469,7 @@ EXTEND
in
mk loc (SchemaVar (kind, schema, typ))
| a = IDENT ->
mk loc (PatVar (ident a))
mk loc (PatVar (U.mk a))
| i = INT ; "--"; j = INT ->
let i = Intervals.V.mk i
and j = Intervals.V.mk j in
......
......@@ -27,6 +27,7 @@ let map f v = let acc0 = make_accu () in set_cdr (f acc0 v) nil; get_accu acc0
let rec eval env e0 = match e0.Typed.exp_descr with
| Typed.Forget (e,_) -> eval env e
| Typed.Var s -> (match Env.find s env with Value.Delayed x -> !x | x -> x)
| Typed.ExtVar _ -> assert false
| Typed.Apply (f,arg) -> eval_apply (eval env f) (eval env arg)
| Typed.Abstraction a -> eval_abstraction env a
| Typed.RecordLitt r -> Record (LabelMap.map (eval env) r)
......@@ -291,6 +292,11 @@ let stack = ref (Array.create 1024 Value.Absent)
let frame = ref 0
let sp = ref 0
let comp_unit () =
let r = Array.sub !stack 0 !sp in
sp := 0;
r
let dump ppf =
Format.fprintf ppf "sp = %i frame = %i@." !sp !frame;
for i = 0 to !sp - 1 do
......@@ -316,6 +322,8 @@ let push x =
let calls = ref 0
let from_comp_unit = ref (fun cu pos -> assert false)
let eval_var env = function
| Env i -> env.(i)
| Global i -> !stack.(i)
......@@ -324,6 +332,7 @@ let eval_var env = function
let rec eval env = function
| Var x -> eval_var env x
| ExtVar (cu,pos) -> !from_comp_unit cu pos
| Apply (false,e1,e2) ->
let v1 = eval env e1 in
let v2 = eval env e2 in
......
......@@ -20,9 +20,11 @@ val eval_binary_op : (int -> (t -> t -> t)) ref
module L : sig
open Lambda
val from_comp_unit: (Types.CompUnit.t -> int -> t) ref
val dump: Format.formatter -> unit
val push: Value.t -> unit
val var: var_loc -> t
val eval: code_item -> unit
val expr: code_item -> t
val comp_unit: unit -> t array
end
......@@ -46,7 +46,7 @@ let dump ppf _ = Format.fprintf ppf "<Intervals.t>"
let rec check = function
| []
| [ Any ] | [ Right _ ] | [ Left _ ] -> ()
| [ Any ] | [ Right _ ] | [ Left _ ] | [ Bounded _ ] -> ()
| (Left i | Bounded (_,i)) :: ((Bounded (j,_) | (Right j)) :: _ as rem) ->
assert (V.compare i j < 0);
check rem
......
......@@ -16,6 +16,42 @@ let (<>) : int -> int -> bool = (<>)
let compare = 1
module CompUnit = struct
include Pool.Make(Utf8)
module Tbl = Inttbl
let pervasives = mk (U.mk "Pervasives")
let close_serialize_ref = ref (fun () -> assert false)
let depend = Inttbl.create ()
let serialize t cu =
if cu != pervasives then Inttbl.add depend cu ();
serialize t cu
let close_serialize () =