[r2002-10-26 01:35:24 by cvscast] Empty log message

Original author: cvscast
Date: 2002-10-26 01:35:24+00:00

driver/cduce.ml

@@ -70,6 +70,29 @@ let rec print_exn ppf = function
   | exn ->
       Format.fprintf ppf "%s@\n" (Printexc.to_string exn)
 
+let debug = function
+  | `Filter (t,p) -> 
+      Format.fprintf ppf "[DEBUG:filter]@\n";
+      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 " x:%a@\n" 
+		     print_norm (Types.descr t)) f
+  | `Accept p ->
+      Format.fprintf ppf "[DEBUG:accept]@\n";
+      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 t
+      and pl = List.map Typer.pat pl in
+      let pl = Array.of_list 
+		 (List.map (fun p -> Patterns.Compile.normal 
+			      (Patterns.descr p)) pl) in
+      Patterns.Compile.show ppf (Types.descr t) pl
+  | _ -> Format.fprintf ppf "Unknown or ill-formed debugging directive !! @\n"
 let phrase ph =
   match ph.descr with
     | Ast.EvalStatement e ->
@@ -77,6 +100,7 @@ let phrase ph =
 	let t = Typer.type_check Typer.Env.empty e Types.any true in
 	Format.fprintf ppf "%a@\n" print_norm t
     | Ast.TypeDecl _ -> ()
+    | Ast.Debug l -> debug l
     | _ -> assert false
 
 let () = 

parser/ast.ml

@@ -11,7 +11,12 @@ and pmodule_item' =
   | FunDecl of abstr
   | LetDecl of ppat * pexpr
   | EvalStatement of pexpr
-  | Debug of string * ([`Pat of ppat | `Expr of pexpr] list)
+  | Debug of debug_directive
+and debug_directive =
+  [ `Filter of ppat * ppat
+  | `Accept of ppat
+  | `Compile of ppat * ppat list ]
+
 
 and pexpr = pexpr' located
 and pexpr' = 

parser/parser.ml

@@ -43,7 +43,16 @@ EXTEND
 
   phrase: [
     [ e = expr -> EvalStatement e
-    | "type"; x = UIDENT; "="; t = pat -> TypeDecl (x,t) ]
+    | "type"; x = UIDENT; "="; t = pat -> TypeDecl (x,t)
+    | "debug"; d = debug_directive -> Debug d
+    ]
+  ];
+
+  debug_directive: [
+    [ LIDENT "filter"; t = pat; p = pat -> `Filter(t,p)
+    | LIDENT "accept"; p = pat -> `Accept p;
+    | LIDENT "compile"; t = pat; p = LIST1 pat -> `Compile (t,p)
+    ]
   ];
 
   expr: [

types/builtin.ml

@@ -4,5 +4,8 @@ let types =
     "Any",     Types.any;
     "Int",     Types.Int.any;
     "Char",    Types.char Chars.any;
-    "Atom",    Types.atom Atoms.any
+    "Atom",    Types.atom Atoms.any;
+    "Pair",    Types.Product.any;
+    "Arrow",   Types.Arrow.any;
+    "Record",  Types.Record.any;
   ];

types/chars.ml

@@ -79,5 +79,6 @@ let print =
        then fun ppf -> 
 	 Unichar.print ppf a
        else fun ppf -> 
+	 if a = 0 && b = max_char then Format.fprintf ppf "Char" else
 	 Format.fprintf ppf "%a--%a" Unichar.print a Unichar.print b
     )

types/intervals.ml

@@ -67,7 +67,7 @@ let rec iadd_bounded l a b = match l with
       iadd_bounded l' (min_big_int a a1) (max_big_int b b1)
   | Left b1 :: l' ->
       iadd_left l' b
-  | Right a1 :: _ -> [Right a]
+  | Right a1 :: _ -> [Right (min_big_int a a1)]
   | Any :: _ -> any
 
 let rec iadd_right l a = match l with

types/patterns.mli

@@ -34,16 +34,10 @@ val filter : Types.descr -> node -> (capture,Types.node) SortedMap.t
 
 (* Pattern matching: compilation *)
 
-module NF : sig
-    type nf
-    type normal
-    val nf : descr -> nf
-    val normal : nf -> normal
-    module Disp : sig
-      val show : Format.formatter -> Types.descr -> normal array -> unit
-    end
-(*
-    val show : Format.formatter -> Types.descr -> nf list -> unit
-    val get : int -> Types.descr * normal list
-*)
+module Compile: sig
+  type normal
+  val normal : descr -> normal
+
+  type dispatcher
+  val show : Format.formatter -> Types.descr -> normal array -> unit
 end

types/types.ml

@@ -638,10 +638,10 @@ struct
       print_union ppf 
 	(Intervals.print d.ints @
 	 Chars.print d.chars @
-	 Atoms.print "AnyAtom" print_atom d.atoms @
-	 Boolean.print "(Any,Any)" print_times d.times @
-	 Boolean.print "(Empty -> Any)" print_arrow d.arrow @
-	 Boolean.print "{ }" print_record d.record
+	 Atoms.print "Atom" print_atom d.atoms @
+	 Boolean.print "Pair" print_times d.times @
+	 Boolean.print "Arrow" print_arrow d.arrow @
+	 Boolean.print "Record" print_record d.record
 	)
   and print_times ppf (t1,t2) =
     Format.fprintf ppf "@[(%a,%a)@]" print t1 print t2