Commit fa1371f9 authored by Pietro Abate's avatar Pietro Abate

[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))
This diff is collapsed.
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 : 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
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: t list -> code_item list -> t array
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment