[r2003-03-23 21:09:48 by cvscast] Empty log message

Original author: cvscast
Date: 2003-03-23 21:09:49+00:00

driver/cduce.ml

@@ -4,7 +4,6 @@ open Ident
 let quiet = ref false
 
 let typing_env = State.ref "Cduce.typing_env" Typer.Env.empty
-let glb_env = State.ref "Cduce.glb_env" Typer.TypeEnv.empty
 let eval_env = Eval.global_env
 
 let print_norm ppf d = 
@@ -15,9 +14,9 @@ let print_value ppf v =
   Location.protect ppf (fun ppf -> Value.print ppf v)
 
 let dump_env ppf =
-  Format.fprintf ppf "Global types:";
-  Typer.TypeEnv.iter (fun x _ -> Format.fprintf ppf " %s" x) !glb_env;
-  Format.fprintf ppf ".@\n";
+(*  Format.fprintf ppf "Global types:";
+  List.iter (fun x _ -> Format.fprintf ppf " %s" x) (Typer.global_types ()); 
+  Format.fprintf ppf ".@\n"; *)
   Eval.Env.iter 
     (fun x v ->
        let t = Typer.Env.find x !typing_env in
@@ -83,23 +82,23 @@ let rec print_exn ppf = function
 let debug ppf = function
   | `Subtype (t1,t2) ->
       Format.fprintf ppf "[DEBUG:subtype]@\n";
-      let t1 = Types.descr (Typer.typ !glb_env t1)
-      and t2 = Types.descr (Typer.typ !glb_env t2) in
+      let t1 = Types.descr (Typer.typ t1)
+      and t2 = Types.descr (Typer.typ t2) in
       Format.fprintf ppf "%a <= %a : %b@\n" print_norm t1 print_norm t2
 	(Types.subtype t1 t2)
   | `Filter (t,p) -> 
       Format.fprintf ppf "[DEBUG:filter]@\n";
-      let t = Typer.typ !glb_env t
-      and p = Typer.pat !glb_env p in
+      let t = Typer.typ t
+      and p = Typer.pat p in
       let f = Patterns.filter (Types.descr t) p in
       List.iter (fun (x,t) ->
 		   Format.fprintf ppf " %s:%a@\n" (Id.value x)
 		     print_norm (Types.descr t)) f
   | `Compile2 (t,pl) -> 
       Format.fprintf ppf "[DEBUG:compile2]@\n";
-(*      let t = Types.descr (Typer.typ !glb_env t) in
+(*      let t = Types.descr (Typer.typ t) in
       let pl = List.map (fun p -> 
-			   let p = Typer.pat !glb_env p in
+			   let p = Typer.pat p in
 			   let a = Types.descr (Patterns.accept p) in
 			   (Some p, Types.cap a t)) pl in
       let d = Patterns.Compiler.make_dispatcher t pl in
@@ -108,13 +107,13 @@ let debug ppf = function
 
   | `Accept p ->
       Format.fprintf ppf "[DEBUG:accept]@\n";
-      let p = Typer.pat !glb_env p in
+      let p = Typer.pat p in
       let t = Patterns.accept p in
       Format.fprintf ppf " %a@\n" Types.Print.print t
   | `Compile (t,pl) ->
       Format.fprintf ppf "[DEBUG:compile]@\n";
-      let t = Typer.typ !glb_env t
-      and pl = List.map (Typer.pat !glb_env) pl in
+      let t = Typer.typ t
+      and pl = List.map Typer.pat pl in
       Patterns.Compile.debug_compile ppf t pl
   | `Normal_record p -> assert false
 
@@ -123,7 +122,7 @@ let debug ppf = function
 let mk_builtin () =
   let bi = List.map (fun (n,t) -> [n, mknoloc (Ast.Internal t)]) 
 	     Builtin.types in
-  glb_env := List.fold_left Typer.register_global_types !glb_env bi
+  List.iter Typer.register_global_types bi
 
 let () = mk_builtin ()
 
@@ -153,7 +152,7 @@ let run ppf ppf_err input =
   let phrase ph = 
     match ph.descr with
       | Ast.EvalStatement e ->
-	  let (fv,e) = Typer.expr !glb_env e in
+	  let (fv,e) = Typer.expr e in
 	  let t = Typer.type_check !typing_env e Types.any true in
 	  Location.dump_loc ppf e.Typed.exp_loc;
 	  if not !quiet then
@@ -163,7 +162,7 @@ let run ppf ppf_err input =
 	    Format.fprintf ppf "=> @[%a@]@\n@." print_value v
       | Ast.LetDecl (p,{descr=Ast.Abstraction _}) -> ()
       | Ast.LetDecl (p,e) ->
-	  let decl = Typer.let_decl !glb_env p e in
+	  let decl = Typer.let_decl p e in
 	  type_decl decl;
 	  eval_decl decl
       | Ast.TypeDecl _ -> ()
@@ -172,7 +171,7 @@ let run ppf ppf_err input =
   in
 
   let do_fun_decls decls =
-    let decls = List.map (fun (p,e) -> Typer.let_decl !glb_env p e) decls in
+    let decls = List.map (fun (p,e) -> Typer.let_decl p e) decls in
     insert_type_bindings (Typer.type_rec_funs !typing_env decls);
     List.iter eval_decl decls
   in
@@ -201,7 +200,7 @@ let run ppf ppf_err input =
 	       (typs, (p,e)::funs)
 	   | _ -> accu
 	) ([],[]) p in
-    glb_env := Typer.register_global_types !glb_env type_decls;
+    Typer.register_global_types type_decls;
     phrases [] p;
     true
   with 

driver/cduce.mli

@@ -2,7 +2,6 @@ val quiet: bool ref
 
 val typing_env: Typer.env ref  (* Types of toplevel bindings *)
 val eval_env: Eval.env ref     (* Values of toplevel bindings *)
-val glb_env: Typer.glb ref     (* Global types *)
 
 val print_exn: Format.formatter -> exn -> unit
 

parser/ast.ml

@@ -149,3 +149,10 @@ and hash_regexp = function
   | Star x -> 5 + 17 * (hash_regexp x)
   | WeakStar x -> 6 + 17 * (hash_regexp x)
   | SeqCapture (x,y) -> 7 + 17 * (Id.hash x) + 257 * (hash_regexp y)
+
+module PpatTable = Hashtbl.Make
+  (struct
+     type t = ppat
+     let equal = equal_ppat
+     let hash = hash_ppat
+   end)

typing/typer.mli

@@ -7,18 +7,13 @@ exception WrongLabel of Types.descr * label
 exception UnboundId of string
 
 module Env : Map.S with type key = Ident.id
-module TypeEnv : Map.S with type key = string
 type env = Types.descr Env.t
-type ti
-type glb = ti TypeEnv.t
 
-val compile_regexp : Ast.regexp -> Ast.ppat -> Ast.ppat
-
-val register_global_types : glb -> (string * Ast.ppat) list -> glb
-val typ : glb -> Ast.ppat -> Typed.ttyp
-val pat : glb -> Ast.ppat -> Typed.tpat
-val expr: glb -> Ast.pexpr -> fv * Typed.texpr
-val let_decl : glb -> Ast.ppat -> Ast.pexpr -> Typed.let_decl
+val register_global_types : (string * Ast.ppat) list -> unit
+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_check: