Commit 12e61f59 authored by Pietro Abate's avatar Pietro Abate

[r2003-09-25 22:48:47 by cvscast] Cleaning

Original author: cvscast
Date: 2003-09-25 22:48:47+00:00
parent bbab8a37
......@@ -4,13 +4,12 @@ open Ident
let quiet = ref false
let toplevel = ref false
let typing_env = State.ref "Cduce.typing_env" Env.empty
let typing_env = State.ref "Cduce.typing_env" Builtin.env
let eval_env = State.ref "Cduce.eval_env" Env.empty
let enter_global_value x v t =
eval_env := Env.add x v !eval_env;
typing_env := Env.add x t !typing_env
typing_env := Typer.enter_value x t !typing_env
let rec is_abstraction = function
| Ast.Abstraction _ -> true
......@@ -32,14 +31,14 @@ let print_value ppf v =
Location.protect ppf (fun ppf -> Value.print ppf v)
let dump_env ppf =
Format.fprintf ppf "Types:%t@." Typer.dump_global_types;
Format.fprintf ppf "Namespace prefixes:@\n%t" Typer.dump_global_ns;
Format.fprintf ppf "Types:%a@." Typer.dump_types !typing_env;
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";
Env.iter
(fun x v ->
let t = Env.find x !typing_env in
let t = Typer.find_value x !typing_env in
Format.fprintf ppf "@[val %a : @[%a = %a@]@]@."
U.print (Id.value x) print_norm t print_value v
)
......@@ -102,41 +101,41 @@ let rec print_exn ppf = function
let debug ppf = function
| `Subtype (t1,t2) ->
Format.fprintf ppf "[DEBUG:subtype]@.";
let t1 = Types.descr (Typer.typ t1)
and t2 = Types.descr (Typer.typ t2) in
let t1 = Types.descr (Typer.typ !typing_env t1)
and t2 = Types.descr (Typer.typ !typing_env t2) in
let s = Types.subtype t1 t2 in
Format.fprintf ppf "%a %a %a : %b@." print_norm t1 print_protect "<=" print_norm t2 s
| `Sample t ->
Format.fprintf ppf "[DEBUG:sample]@.";
(try
let t = Types.descr (Typer.typ t) in
let t = Types.descr (Typer.typ !typing_env t) in
Format.fprintf ppf "%a@." print_sample (Sample.get t)
with Not_found ->
Format.fprintf ppf "Empty type : no sample !@.")
| `Filter (t,p) ->
Format.fprintf ppf "[DEBUG:filter]@.";
let t = Typer.typ t
and p = Typer.pat p in
let t = Typer.typ !typing_env t
and p = Typer.pat !typing_env p in
let f = Patterns.filter (Types.descr t) p in
List.iter (fun (x,t) ->
Format.fprintf ppf " %a:%a@." U.print (Id.value x)
print_norm (Types.descr t)) f
| `Accept p ->
Format.fprintf ppf "[DEBUG:accept]@.";
let p = Typer.pat p in
let p = Typer.pat !typing_env p in
let t = Patterns.accept p in
Format.fprintf ppf " %a@." Types.Print.print (Types.descr t)
| `Compile (t,pl) ->
Format.fprintf ppf "[DEBUG:compile]@.";
let t = Typer.typ t
and pl = List.map Typer.pat pl in
let t = Typer.typ !typing_env t
and pl = List.map (Typer.pat !typing_env) pl in
Patterns.Compile.debug_compile ppf t pl
let insert_bindings ppf =
List.iter2
(fun (x,t) (y,v) ->
assert (x = y);
typing_env := Env.add x t !typing_env;
typing_env := Typer.enter_value x t !typing_env;
eval_env := Env.add x v !eval_env;
if not !quiet then
Format.fprintf ppf "val %a : @[@[%a@] =@ @[%a@]@]@."
......@@ -144,7 +143,7 @@ let insert_bindings ppf =
let rec collect_funs ppf accu = function
| { descr = Ast.FunDecl e } :: rest ->
let (_,e) = Typer.expr e in
let (_,e) = Typer.expr !typing_env e in
collect_funs ppf (e::accu) rest
| rest ->
let typs = Typer.type_rec_funs !typing_env accu in
......@@ -157,7 +156,8 @@ let rec collect_types ppf accu = function
| { descr = Ast.TypeDecl (x,t) } :: rest ->
collect_types ppf ((x,t) :: accu) rest
| rest ->
Typer.register_global_types accu;
typing_env :=
Typer.enter_types (Typer.type_defs !typing_env accu) !typing_env;
rest
let rec phrases ppf phs = match phs with
......@@ -169,10 +169,10 @@ let rec phrases ppf phs = match phs with
Typer.register_schema name schema;
phrases ppf rest
| { descr = Ast.Namespace (pr,ns) } :: rest ->
Typer.register_global_ns pr ns;
typing_env := Typer.enter_ns pr ns !typing_env;
phrases ppf rest
| { descr = Ast.EvalStatement e } :: rest ->
let (fv,e) = Typer.expr e in
let (fv,e) = Typer.expr !typing_env e in
let t = Typer.type_check !typing_env e Types.any true in
Typer.report_unused_branches ();
if not !quiet then
......@@ -182,7 +182,7 @@ let rec phrases ppf phs = match phs with
Format.fprintf ppf "- : @[@[%a@] =@ @[%a@]@]@." print_norm t print_value v;
phrases ppf rest
| { descr = Ast.LetDecl (p,e) } :: rest ->
let decl = Typer.let_decl p e in
let decl = Typer.let_decl !typing_env p e in
let typs = Typer.type_let_decl !typing_env decl in
Typer.report_unused_branches ();
let vals = Eval.eval_let_decl !eval_env decl in
......@@ -198,7 +198,7 @@ let rec phrases ppf phs = match phs with
dump_env ppf;
phrases ppf rest
| { descr = Ast.Directive `Reinit_ns } :: rest ->
Typer.set_ns_table_for_printer ();
Typer.set_ns_table_for_printer !typing_env;
phrases ppf rest
| [] -> ()
......
......@@ -18,12 +18,10 @@ let types =
"Bool", bool
]
let () =
List.iter
(fun (n,t) ->
Typer.register_global_types
[ Ident.ident (Ident.U.mk n),
Location.mknoloc (Ast.Internal t)])
let env =
List.fold_left
(fun accu (n,t) -> Typer.enter_type (Ident.ident (Ident.U.mk n)) t accu)
Typer.empty_env
types
(* Operators *)
......
(*
No values exported.
Are you looking for builtin types? Then look at types/builtin_defs.mli
*)
val env: Typer.env
(* Typing environment with built-in types *)
This diff is collapsed.
......@@ -10,28 +10,30 @@ exception Error of string
val warning: Location.loc -> string -> unit
val error: Location.loc -> string -> 'a
type tenv
(*
val typ_def: tenv -> (id * Ast.ppat) list -> (id * Types.t)
val typ_expr: tenv -> Ast.ppat -> Types.Node.t
val pat_expr: tenv -> Ast.ppat -> Patterns.node
*)
type env
val empty_env: env
val get_ns_table : env -> Ns.table
val get_ns_table : tenv -> Ns.table
val enter_ns : U.t -> Ns.t -> env -> env
val register_global_types : (id * Ast.ppat) list -> unit
val register_global_ns : U.t -> Ns.t -> unit
val dump_global_types: Format.formatter -> unit
val dump_global_ns: Format.formatter -> unit
val enter_value: id -> Types.t -> env -> env
val enter_values: (id * Types.t) list -> env -> env
val find_value: id -> env -> Types.t
val set_ns_table_for_printer: unit -> unit
val enter_type: id -> Types.t -> env -> env
val enter_types: (id * Types.t) list -> env -> env
val find_type: id -> env -> Types.t
val typ : Ast.ppat -> Typed.ttyp
val pat : Ast.ppat -> Typed.tpat
val expr: Ast.pexpr -> fv * Typed.texpr
val let_decl : Ast.ppat -> Ast.pexpr -> Typed.let_decl
val type_defs: env -> (id * Ast.ppat) list -> (id * Types.t) list
val typ: env -> Ast.ppat -> Types.Node.t
val pat: env -> Ast.ppat -> Patterns.node
type env = Types.descr Env.t
val dump_types: Format.formatter -> env -> unit
val dump_ns: Format.formatter -> env -> unit
val set_ns_table_for_printer: env -> unit
val expr: env -> Ast.pexpr -> fv * Typed.texpr
val let_decl : env -> Ast.ppat -> Ast.pexpr -> Typed.let_decl
val type_check:
env -> Typed.texpr -> Types.descr -> bool -> Types.descr
......@@ -39,9 +41,9 @@ val type_check:
has type [t] under typing environment [env]; if [precise=true],
also returns a possible more precise type for [e].
*)
val type_let_decl: env -> Typed.let_decl -> (id * Types.descr) list
val type_let_decl: env -> Typed.let_decl -> (id * Types.t) list
val type_rec_funs: env -> Typed.texpr list -> (id * Types.descr) list
val type_rec_funs: env -> Typed.texpr list -> (id * Types.t) list
(* Assume that all the expressions are Abstractions *)
val report_unused_branches : unit -> unit
......@@ -49,7 +51,7 @@ val report_unused_branches : unit -> unit
val clear_unused_branches : unit -> unit
val flatten: Location.loc ->
(Types.descr -> bool -> Types.descr) -> (Types.descr -> bool -> Types.descr)
(Types.t -> bool -> Types.t) -> (Types.t -> bool -> Types.t)
(** {2 Schema stuff} *)
......@@ -68,6 +70,6 @@ val get_schema_type: string * string -> Types.descr
(* Operators *)
val register_unary_op: string -> (tenv -> Typed.unary_op) -> unit
val register_binary_op : string -> (tenv -> Typed.binary_op) -> unit
val register_unary_op: string -> (env -> Typed.unary_op) -> unit
val register_binary_op : string -> (env -> Typed.binary_op) -> unit
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