Commit fa1371f9 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2003-12-12 22:59:37 by afrisch] Cleaning: remove old evaluator

Original author: afrisch
Date: 2003-12-12 22:59:38+00:00
parent f7f83a86
......@@ -173,7 +173,8 @@ DTD2CDUCE = tools/dtd2cduce.cmo
ALL_OBJECTS = $(OBJECTS) $(CQL_OBJECTS) \
driver/run.cmo driver/examples.cmo driver/webiface.cmo \
tools/dtd2cduce.cmo tools/validate.cmo
tools/dtd2cduce.cmo tools/validate.cmo \
$(CQL_OBJECTS_RUN)
ALL_INTERFACES = schema/schema_types.mli
DEPEND = $(ALL_OBJECTS:.cmo=.ml) $(ALL_OBJECTS:.cmo=.mli) $(ALL_INTERFACES)
......
......@@ -108,8 +108,8 @@ schema/schema_parser.cmx: misc/q_symbol.cmo misc/encodings.cmx types/intervals.c
runtime/value.cmx schema/schema_parser.cmi
parser/location.cmo: misc/q_symbol.cmo parser/location.cmi
parser/location.cmx: misc/q_symbol.cmo parser/location.cmi
parser/url.cmo: misc/q_symbol.cmo parser/url.cmi
parser/url.cmx: misc/q_symbol.cmo parser/url.cmi
parser/url.cmo: misc/q_symbol.cmo parser/location.cmi parser/url.cmi
parser/url.cmx: misc/q_symbol.cmo parser/location.cmx parser/url.cmi
parser/ulexer.cmo: misc/q_symbol.cmo parser/ulexer.cmi
parser/ulexer.cmx: misc/q_symbol.cmo parser/ulexer.cmi
parser/ast.cmo: misc/q_symbol.cmo types/builtin_defs.cmi types/chars.cmi types/ident.cmo \
......@@ -177,13 +177,11 @@ runtime/print_xml.cmx: misc/q_symbol.cmo types/atoms.cmx misc/encodings.cmx type
runtime/eval.cmo: misc/q_symbol.cmo types/builtin_defs.cmi types/ident.cmo compile/lambda.cmo \
types/patterns.cmi runtime/run_dispatch.cmi schema/schema_common.cmi \
schema/schema_types.cmi schema/schema_validator.cmi types/sequence.cmi \
typing/typed.cmo typing/typer.cmi types/types.cmi runtime/value.cmi \
runtime/eval.cmi
typing/typer.cmi types/types.cmi runtime/value.cmi runtime/eval.cmi
runtime/eval.cmx: misc/q_symbol.cmo types/builtin_defs.cmx types/ident.cmx compile/lambda.cmx \
types/patterns.cmx runtime/run_dispatch.cmx schema/schema_common.cmx \
schema/schema_types.cmi schema/schema_validator.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
compile/compile.cmo: misc/q_symbol.cmo parser/ast.cmo types/ident.cmo compile/lambda.cmo \
parser/location.cmi types/patterns.cmi misc/serialize.cmi \
typing/typed.cmo typing/typer.cmi types/types.cmi compile/compile.cmi
......@@ -234,10 +232,12 @@ query/query.cmo: misc/q_symbol.cmo parser/ast.cmo types/atoms.cmi types/builtin_
query/query.cmx: misc/q_symbol.cmo parser/ast.cmx types/atoms.cmx types/builtin_defs.cmx \
types/chars.cmx types/ident.cmx types/intervals.cmx parser/location.cmx \
parser/parser.cmx types/types.cmx query/query.cmi
query/query_parse.cmo: misc/q_symbol.cmo parser/ast.cmo types/ident.cmo parser/location.cmi \
parser/parser.cmi query/query.cmi types/sequence.cmi
query/query_parse.cmx: misc/q_symbol.cmo parser/ast.cmx types/ident.cmx parser/location.cmx \
parser/parser.cmx query/query.cmx types/sequence.cmx
query/query_parse.cmo: misc/q_symbol.cmo parser/ast.cmo types/atoms.cmi types/ident.cmo \
parser/location.cmi parser/parser.cmi query/query.cmi types/sequence.cmi \
types/types.cmi
query/query_parse.cmx: misc/q_symbol.cmo parser/ast.cmx types/atoms.cmx types/ident.cmx \
parser/location.cmx parser/parser.cmx query/query.cmx types/sequence.cmx \
types/types.cmx
driver/run.cmo: misc/q_symbol.cmo driver/cduce.cmi types/ident.cmo driver/librarian.cmi \
runtime/load_xml.cmi parser/location.cmi types/sequence.cmi \
misc/state.cmi misc/stats.cmi parser/ulexer.cmi runtime/value.cmi
......@@ -252,6 +252,8 @@ tools/validate.cmo: misc/q_symbol.cmo schema/schema_common.cmi schema/schema_par
schema/schema_types.cmi
tools/validate.cmx: misc/q_symbol.cmo schema/schema_common.cmx schema/schema_parser.cmx \
schema/schema_types.cmi
query/query_run.cmo: misc/q_symbol.cmo query/query.cmi driver/run.cmo
query/query_run.cmx: misc/q_symbol.cmo query/query.cmx driver/run.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
......@@ -286,8 +288,8 @@ 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/print_xml.cmi: misc/q_symbol.cmo misc/ns.cmi runtime/value.cmi
runtime/eval.cmi: misc/q_symbol.cmo types/ident.cmo compile/lambda.cmo typing/typed.cmo \
types/types.cmi runtime/value.cmi
runtime/eval.cmi: misc/q_symbol.cmo types/ident.cmo compile/lambda.cmo types/types.cmi \
runtime/value.cmi
compile/compile.cmi: misc/q_symbol.cmo parser/ast.cmo types/ident.cmo compile/lambda.cmo \
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 \
......
......@@ -4,8 +4,8 @@ open Ident
exception InvalidInputFilename of string
exception InvalidObjectFilename of string
(* if set to false toplevel exception aren't cought. Useful for debugging with
* OCAMLRUNPARAM="b" *)
(* if set to false toplevel exception aren't cought.
* Useful for debugging with OCAMLRUNPARAM="b" *)
let catch_exceptions = true
(* retuns a filename without the suffix suff if any *)
......@@ -21,25 +21,18 @@ let toplevel = ref false
let typing_env = State.ref "Cduce.typing_env" Builtin.env
let eval_env = State.ref "Cduce.eval_env" Eval.empty
let compile_env = State.ref "Cduce.compile_env" Compile.empty
let do_compile = ref false
let get_global_value v =
if !do_compile
then Eval.L.var (Compile.find v !compile_env)
else Eval.find_value v !eval_env
Eval.var (Compile.find v !compile_env)
let get_global_type v =
Typer.find_value v !typing_env
let enter_global_value x v t =
typing_env := Typer.enter_value x t !typing_env;
if !do_compile
then (compile_env := Compile.enter_global !compile_env x; Eval.L.push v)
else eval_env := Eval.enter_value x v !eval_env
compile_env := Compile.enter_global !compile_env x;
Eval.push v
let rec is_abstraction = function
| Ast.Abstraction _ -> true
......@@ -171,19 +164,20 @@ let display ppf l =
(fun (x,t) -> dump_value ppf x t (get_global_value x))
l
let eval_quiet e =
let (e,t) = Typer.type_expr !typing_env e in
let e = Compile.compile_eval !compile_env e in
Eval.expr e
let eval ppf e =
let (e,t) = Typer.type_expr !typing_env e in
if not !quiet then
Location.dump_loc ppf (e.Typed.exp_loc,`Full);
let v =
if !do_compile then
let e = Compile.compile_eval !compile_env e in
Eval.L.expr e
else
Eval.eval !eval_env e
in
let e = Compile.compile_eval !compile_env e in
let v = Eval.expr e in
if not !quiet then
Format.fprintf ppf "- : @[@[%a@] =@ @[%a@]@]@."
print_norm t print_value v;
......@@ -192,14 +186,10 @@ let eval ppf e =
let let_decl ppf p e =
let (tenv,decl,typs) = Typer.type_let_decl !typing_env p e in
let () =
if !do_compile then
let (env,decl) = Compile.compile_let_decl !compile_env decl in
Eval.L.eval decl;
compile_env := env
else
eval_env := Eval.eval_let_decl !eval_env decl
in
let (env,decl) = Compile.compile_let_decl !compile_env decl in
Eval.eval decl;
compile_env := env;
typing_env := tenv;
display ppf typs
......@@ -207,14 +197,10 @@ let let_decl ppf p e =
let let_funs ppf funs =
let (tenv,funs,typs) = Typer.type_let_funs !typing_env funs in
let () =
if !do_compile then
let (env,funs) = Compile.compile_rec_funs !compile_env funs in
Eval.L.eval funs;
compile_env := env;
else
eval_env := Eval.eval_rec_funs !eval_env funs
in
let (env,funs) = Compile.compile_rec_funs !compile_env funs in
Eval.eval funs;
compile_env := env;
typing_env := tenv;
display ppf typs
......@@ -326,9 +312,7 @@ let rec phrases ppf phs = match phs with
directive_help ppf;
phrases ppf rest
| { descr = Ast.Directive (`Dump pexpr) } :: rest ->
Format.fprintf ppf "%a@."
Value.dump_xml (Eval.eval !eval_env
(fst (Typer.type_expr !typing_env pexpr)));
Format.fprintf ppf "%a@." Value.dump_xml (eval_quiet pexpr);
phrases ppf rest
| [] -> ()
......
val quiet: bool ref
val toplevel: bool ref
val do_compile: bool ref
val enter_global_value : Ident.id -> Value.t -> Types.descr -> unit
val script : Format.formatter -> Format.formatter -> char Stream.t -> bool
......
......@@ -186,9 +186,7 @@ let rec run argv id =
match cu.vals with
| None ->
List.iter (run argv) cu.depends;
Eval.L.push argv;
List.iter Eval.L.eval cu.code;
cu.vals <- Some (Eval.L.comp_unit ())
cu.vals <- Some (Eval.comp_unit [argv] cu.code)
| Some _ -> ()
let import id = ignore (load id)
......@@ -196,21 +194,8 @@ 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 :=
Eval.from_comp_unit :=
(fun cu i ->
match (load cu).vals with
| None -> assert false
| Some a -> a.(i));
Eval.from_comp_unit :=
(fun cu id ->
let c = load cu in
let pos =
match Compile.find id c.compile with
| Lambda.Global i -> i
| _ -> assert false in
run Value.nil cu;
match c.vals with
| None -> assert false
| Some a -> a.(pos))
| Some a -> a.(i))
open Value
open Run_dispatch
open Ident
type env = t Env.t
let empty = Env.empty
open Lambda
let eval_unary_op = ref (fun _ -> assert false)
let eval_binary_op = ref (fun _ _ -> assert false)
let enter_value = Env.add
let enter_values l env =
List.fold_left (fun env (x,v) -> Env.add x v env) env l
let find_value = Env.find
(* To write tail-recursive map-like iteration *)
let make_accu () = Pair(nil,Absent)
let make_accu () = Value.Pair(nil,Absent)
let get_accu a = snd (Obj.magic a)
let map f v = let acc0 = make_accu () in set_cdr (f acc0 v) nil; get_accu acc0
(* Evaluation of expressions *)
let from_comp_unit = ref (fun cu i -> assert false)
let eval_apply = ref (fun f x -> assert false)
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 (cu,i) -> !from_comp_unit cu i
| 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)
| Typed.Pair (e1,e2) -> Pair (eval env e1, eval env e2)
| Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }) ->
Xml (eval env e1, eval env e2, eval env e3)
| Typed.Xml (_,_) -> assert false
| Typed.Cst c -> const c
| Typed.String (i,j,s,e) -> String_utf8 (i,j,s, eval env e)
| Typed.Match (arg,brs) -> eval_branches env brs (eval env arg)
| Typed.Map (arg,brs) -> eval_map env brs (eval env arg)
| Typed.Xtrans (arg,brs) -> eval_xtrans env brs (eval env arg)
| Typed.Try (arg,brs) -> eval_try env arg brs
| Typed.Transform (arg,brs) -> eval_transform env brs (eval env arg)
| Typed.Dot (e, l) -> eval_dot l (eval env e)
| Typed.RemoveField (e, l) -> eval_remove_field l (eval env e)
| Typed.UnaryOp (op,e) -> !eval_unary_op op (eval env e)
| Typed.BinaryOp (op,e1,e2) -> !eval_binary_op op (eval env e1) (eval env e2)
| Typed.Validate (e, kind, schema, name) ->
eval_validate env e kind schema name
| Typed.Ref (e,t) -> eval_ref env e t
and eval_ref env e t=
let r = ref (eval env e) in
let get =
Abstraction ([Sequence.nil_type, Types.descr t], fun _ -> !r)
and set =
Abstraction
([Types.descr t, Sequence.nil_type], fun x -> r := x; nil) in
Record (Builtin_defs.mk_ref ~get ~set)
and eval_validate env e kind schema_name name =
let schema = Typer.get_schema schema_name in
try
let validate =
match Schema_common.get_component kind name schema with
| Schema_types.Type x -> Schema_validator.validate_type x schema
| Schema_types.Element x -> Schema_validator.validate_element x schema
| Schema_types.Attribute x ->
assert false (* TODO see schema/schema_validator.mli *)
(* Schema_validator.validate_attribute x schema *)
| Schema_types.Attribute_group x ->
Schema_validator.validate_attribute_group x schema
| Schema_types.Model_group x ->
Schema_validator.validate_model_group x schema
in
validate (eval env e)
with Schema_common.XSI_validation_error msg ->
failwith' ("Schema validation failure: " ^ msg)
and eval_try env arg brs =
try eval env arg
with (CDuceExn v) as exn ->
match eval_branches env brs v with
| Value.Absent -> raise exn
| x -> x
and eval_abstraction env a =
let env =
IdSet.fold
(fun accu x -> Env.add x (Env.find x env) accu)
Env.empty a.Typed.fun_fv in
match a.Typed.fun_name with
| None ->
Abstraction (a.Typed.fun_iface, eval_branches env a.Typed.fun_body)
| Some f ->
let self = ref Value.Absent in
let env = Env.add f (Value.Delayed self) env in
let a =
Abstraction
(a.Typed.fun_iface, eval_branches env a.Typed.fun_body) in
self := a;
a
(*
and eval_apply f arg = match f with
| Abstraction (_,clos) -> clos arg
| _ -> assert false
*)
and eval_branches env brs arg =
let (disp, rhs) = Typed.dispatcher brs in
let (code, bindings) = run_dispatcher disp arg in
match rhs.(code) with
| Patterns.Compile.Match (bind,e) ->
let env =
List.fold_left (
fun env (x,i) ->
if (i == -1) then Env.add x arg env
else Env.add x bindings.(i) env) env bind in
eval env e
| Patterns.Compile.Fail -> Value.Absent
and eval_let_decl env l =
let v = eval env l.Typed.let_body in
let (disp,bind) = Typed.dispatcher_let_decl l in
let (_,bindings) = run_dispatcher disp v in
List.fold_left
(fun env (x,i) ->
let v = if (i == -1) then v else bindings.(i) in
enter_value x v env
)
env
bind
and eval_rec_funs env l =
let slots =
List.fold_left
(fun accu -> function
| { Typed.exp_descr=Typed.Abstraction
{ Typed.fun_name = Some f } } as e ->
(f, e, ref Absent) :: accu
| _ -> assert false
) [] l in
let env' =
List.fold_left
(fun env (f, _ ,s) -> Env.add f (Delayed s) env)
env slots in
List.iter (fun (_, e, s) -> s := eval env' e) slots;
env'
and eval_map env brs v =
map (eval_map_aux env brs) v
and eval_map_aux env brs acc = function
| Pair (x,y) ->
let x = eval_branches env brs x in
let acc' = Pair (x, Absent) in
set_cdr acc acc';
eval_map_aux env brs acc' y
| String_latin1 (_,_,_,_) | String_utf8 (_,_,_,_) as v ->
eval_map_aux env brs acc (normalize v)
| Concat (x,y) ->
let acc = eval_map_aux env brs acc x in
eval_map_aux env brs acc y
| _ -> acc
and eval_transform env brs v =
map (eval_transform_aux env brs) v
and eval_transform_aux env brs acc = function
| Pair (x,y) ->
(match eval_branches env brs x with
| Value.Absent -> eval_transform_aux env brs acc y
| x -> eval_transform_aux env brs (append_cdr acc x) y)
| String_latin1 (_,_,_,q) | String_utf8 (_,_,_,q) as v ->
(* TODO: raise this test outside the loop *)
if Types.Char.is_empty (brs.Typed.br_accept)
then eval_transform_aux env brs acc q
else eval_transform_aux env brs acc (normalize v)
| Concat (x,y) ->
let acc = eval_transform_aux env brs acc x in
eval_transform_aux env brs acc y
| _ -> acc
and eval_xtrans env brs v =
map (eval_xtrans_aux env brs) v
and eval_xtrans_aux env brs acc = function
| String_utf8 (s,i,j,q) as v ->
if Types.Char.is_empty (brs.Typed.br_accept)
then
let acc' = String_utf8 (s,i,j, Absent) in
set_cdr acc acc';
eval_xtrans_aux env brs acc' q
else eval_xtrans_aux env brs acc (normalize v)
| String_latin1 (s,i,j,q) as v ->
if Types.Char.is_empty (brs.Typed.br_accept)
then
let acc' = String_latin1 (s,i,j, Absent) in
set_cdr acc acc';
eval_xtrans_aux env brs acc' q
else eval_xtrans_aux env brs acc (normalize v)
| Concat (x,y) ->
let acc = eval_xtrans_aux env brs acc x in
eval_xtrans_aux env brs acc y
| Pair (x,y) ->
let acc =
match eval_branches env brs x with
| Absent ->
let x = match x with
| Xml (tag, attr, child) ->
let child = eval_xtrans env brs child in
Xml (tag, attr, child)
| x -> x in
let acc' = Pair (x, Absent) in
set_cdr acc acc';
acc'
| x -> append_cdr acc x
in
eval_xtrans_aux env brs acc y
| _ -> acc
and eval_dot l = function
| Record r -> LabelMap.assoc l r
| _ -> assert false
and eval_remove_field l = function
| Record r -> Record (LabelMap.remove l r)
| _ -> assert false
(* Non tail-rec version:
and eval_transform env brs = function
| Pair (x,y) ->
(match eval_branches env brs x with
| Value.Absent -> eval_transform env brs y
| x -> concat x (eval_transform env brs y))
| String_latin1 (_,_,_,q) | String_utf8 (_,_,_,q) as v ->
if Types.Char.is_empty (brs.Typed.br_accept)
then eval_transform env brs q
else eval_transform env brs (normalize v)
| q -> q
and eval_xtrans env brs = function
| String_utf8 (s,i,j,q) as v ->
if Types.Char.is_empty (brs.Typed.br_accept)
then String_utf8 (s,i,j, eval_xtrans env brs q)
else eval_xtrans env brs (normalize v)
| String_latin1 (s,i,j,q) as v ->
if Types.Char.is_empty (brs.Typed.br_accept)
then String_latin1 (s,i,j, eval_xtrans env brs q)
else eval_xtrans env brs (normalize v)
| Pair (x,y) ->
(match eval_branches env brs x with
| Absent ->
let x = match x with
| Xml (tag, attr, child) ->
let child = eval_xtrans env brs child in
Xml (tag, attr, child)
| x -> x in
let y = eval_xtrans env brs y in
Pair (x,y)
| x ->
let y = eval_xtrans env brs y in
concat x y)
| q -> q
and eval_map env brs = function
| Pair (x,y) ->
let x = eval_branches env brs x in
Pair (x, eval_map env brs y)
| String_latin1 (_,_,_,_) | String_utf8 (_,_,_,_) as v ->
eval_map env brs (normalize v)
| q -> q
*)
(* Evaluator for "compiled" expressions *)
module L = struct
open Lambda
let dispatcher brs =
match brs.brs_compiled with
| Some d -> d
......@@ -305,15 +28,10 @@ let dispatcher brs =
x
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;
......@@ -338,8 +56,6 @@ let push x =
set stack !sp x;
incr sp
let calls = ref 0
let from_comp_unit = ref (fun cu pos -> assert false)
let eval_var env = function
......@@ -395,9 +111,6 @@ and eval_abstraction env slots iface body =
a
and eval_apply f arg =
(* Format.fprintf Format.std_formatter
"Apply %i@." !calls;
incr calls;*)
match f with
| Value.Abstraction2 (local_env,_,body) ->
let saved_frame = !frame and saved_sp = !sp in
......@@ -410,9 +123,6 @@ and eval_apply f arg =
| _ -> assert false
and eval_apply_tail_rec f arg =
(* Format.fprintf Format.std_formatter
"Apply tail %i@." !calls;
incr calls;*)
match f with
| Value.Abstraction2 (local_env,_,body) ->
sp := !frame;
......@@ -555,7 +265,6 @@ and eval_dot l = function
Value.print Format.std_formatter v;
failwith ("Cannot find field " ^ (Label.to_string (LabelPool.value l)))
and eval_remove_field l = function
| Value.Record r -> Value.Record (LabelMap.remove l r)
| _ -> assert false
......@@ -598,6 +307,8 @@ let eval = function
| Let_decl (p,e) -> eval_let_decl p e
| Let_funs funs -> eval_rec_funs funs
end
let () = eval_apply := L.eval_apply
let comp_unit init code =
List.iter push init;
List.iter eval code;
let r = Array.sub !stack 0 !sp in sp := 0; r
open Value
open Ident
type env
val empty: env
val from_comp_unit: (Types.CompUnit.t -> id -> t) ref
val enter_value: id -> t -> env -> env
val enter_values: (id * t) list -> env -> env
val find_value: id -> env -> t
val eval: env -> Typed.texpr -> t
val eval_let_decl: env -> Typed.let_decl -> env
val eval_rec_funs: env -> Typed.texpr list -> env
val eval_unary_op: (int -> (t -> t)) ref
val eval_binary_op : (int -> (t -> t -> t)) ref
module L :