[r2002-10-16 16:18:48 by cvscast] Empty log message

Original author: cvscast
Date: 2002-10-16 16:18:48+00:00

depend

@@ -2,10 +2,10 @@ parser/ast.cmo: parser/location.cmi types/patterns.cmi types/types.cmi
 parser/ast.cmx: parser/location.cmx types/patterns.cmx types/types.cmx 
 parser/location.cmo: parser/location.cmi 
 parser/location.cmx: parser/location.cmi 
-parser/parser.cmo: parser/ast.cmo parser/location.cmi types/types.cmi \
-    parser/parser.cmi 
-parser/parser.cmx: parser/ast.cmx parser/location.cmx types/types.cmx \
-    parser/parser.cmi 
+parser/parser.cmo: parser/ast.cmo types/chars.cmi parser/location.cmi \
+    types/types.cmi parser/parser.cmi 
+parser/parser.cmx: parser/ast.cmx types/chars.cmx parser/location.cmx \
+    types/types.cmx parser/parser.cmi 
 parser/parser.cmi: parser/ast.cmo 
 typing/typed.cmo: parser/location.cmi types/patterns.cmi types/types.cmi 
 typing/typed.cmx: parser/location.cmx types/patterns.cmx types/types.cmx 
@@ -38,17 +38,17 @@ types/strings.cmx: types/boolean.cmx types/intervals.cmx types/recursive.cmx \
     types/strings.cmi 
 types/type_bool.cmo: types/boolean.cmi types/recursive.cmi 
 types/type_bool.cmx: types/boolean.cmx types/recursive.cmx 
-types/types.cmo: types/atoms.cmi types/boolean.cmi types/intervals.cmi \
-    types/recursive.cmi types/sortedList.cmi types/sortedMap.cmi \
-    types/strings.cmi types/types.cmi 
-types/types.cmx: types/atoms.cmx types/boolean.cmx types/intervals.cmx \
-    types/recursive.cmx types/sortedList.cmx types/sortedMap.cmx \
-    types/strings.cmx types/types.cmi 
+types/types.cmo: types/atoms.cmi types/boolean.cmi types/chars.cmi \
+    types/intervals.cmi types/recursive.cmi types/sortedList.cmi \
+    types/sortedMap.cmi types/strings.cmi types/types.cmi 
+types/types.cmx: types/atoms.cmx types/boolean.cmx types/chars.cmx \
+    types/intervals.cmx types/recursive.cmx types/sortedList.cmx \
+    types/sortedMap.cmx types/strings.cmx types/types.cmi 
 types/boolean.cmi: types/sortedList.cmi 
 types/patterns.cmi: types/sortedList.cmi types/sortedMap.cmi types/types.cmi 
 types/sortedMap.cmi: types/sortedList.cmi 
 types/syntax.cmi: types/patterns.cmi types/types.cmi 
-types/types.cmi: types/sortedMap.cmi types/strings.cmi 
+types/types.cmi: types/chars.cmi types/sortedMap.cmi types/strings.cmi 
 driver/cduce.cmo: parser/ast.cmo parser/location.cmi parser/parser.cmi \
     typing/typer.cmi types/types.cmi 
 driver/cduce.cmx: parser/ast.cmx parser/location.cmx parser/parser.cmx \

driver/cduce.ml

@@ -28,9 +28,19 @@ let phrase ph =
 	let (fv,e) = Typer.expr e in
 	let t = Typer.compute_type Typer.Env.empty e in
 	Format.fprintf ppf "%a@\n" Types.Print.print_descr t;
+    | Ast.TypeDecl _ -> ()
     | _ -> assert false
 
 let () = 
-  try List.iter phrase (prog ())
+  try 
+    let p = prog () in
+    let type_decls = 
+      List.fold_left
+	(fun accu ph -> match ph.descr with
+	   | Ast.TypeDecl (x,t) -> (x,t) :: accu
+	   | _ -> accu
+	) [] p in
+    Typer.register_global_types type_decls;
+    List.iter phrase p
   with exn -> print_exn ppf exn
 	

parser/parser.ml

@@ -24,7 +24,12 @@ open Ast
   GLOBAL: prog expr pat regexp const;
 
   prog: [
-    [ l = LIST0 [ e = expr; ";;" -> mk loc (EvalStatement e) ] -> l ]
+    [ l = LIST0 [ p = phrase; ";;" -> mk loc p ]; ";;" -> l ]
+  ];
+
+  phrase: [
+    [ e = expr -> EvalStatement e
+    | "type"; x = UIDENT; "="; t = pat -> TypeDecl (x,t) ]
   ];
 
   expr: [
@@ -114,6 +119,8 @@ open Ast
       | i = INT ; "--"; j = INT -> 
           let i = int_of_string i and j = int_of_string j in
           mk loc (Internal (Types.interval i j))
+      | i = char ; "--"; j = char ->
+          mk loc (Internal (Types.char_class i j))
       | c = const -> mk loc (Internal (Types.constant c))
       | "("; l = LIST1 pat SEP ","; ")" -> multi_prod loc l
       | "["; r = [ r = regexp -> r | -> Epsilon ];
@@ -137,11 +144,19 @@ open Ast
           | h::t -> List.fold_left (fun t1 t2 -> mk loc (And (t1,t2))) h t
       ] ];
   
+  char:
+    [ 
+      [ c = CHAR -> Chars.Unichar.from_char (Token.eval_char c)
+      | "!"; i = INT -> Chars.Unichar.from_int (int_of_string i) ]
+    ];
+     
+
   const:
     [ 
       [ i = INT -> Types.Integer (int_of_string i)
       | x = STRING -> Types.String (Token.eval_string x)
-      | "`"; a = [LIDENT | UIDENT] -> Types.Atom (Types.mk_atom a) ]
+      | "`"; a = [LIDENT | UIDENT] -> Types.Atom (Types.mk_atom a) 
+      | c = char -> Types.Char c ]
     ];
 
   tag_spec:

types/chars.ml

@@ -8,6 +8,9 @@ module Unichar = struct
       failwith "Chars.from_int: code point out of bound";
     c
 
+  let from_char c =
+    Char.code c
+
   let to_int c = c
 
   let print ppf c =
@@ -30,8 +33,9 @@ let to_int c = c
 let empty = []
 let full = [0,max_char]
 
-let char_class (a,b) =
-  if a<=b then [a,b] else empty
+let char_class a b = if a<=b then [a,b] else empty
+
+let atom a = [a,a]
 
 let rec add l ((a,b) as i) = match l with
   | [] -> 

types/chars.mli

 module Unichar : sig
   type t
   val from_int: int -> t
+  val from_char: char -> t
   val to_int: t -> int
+
   val print : Format.formatter -> t -> unit
 end
 
@@ -12,7 +14,8 @@ val full  : t
 val cup   : t -> t -> t
 val cap   : t -> t -> t
 val diff  : t -> t -> t
-val char_class  : Unichar.t * Unichar.t -> t
+val char_class  : Unichar.t -> Unichar.t -> t
+val atom  : Unichar.t -> t
 
 
 val is_empty : t -> bool

types/types.ml

@@ -6,7 +6,7 @@ open Printf
 type label = int
 type atom  = int
 
-type const = Integer of int | Atom of atom | String of string
+type const = Integer of int | Atom of atom | String of string | Char of Chars.Unichar.t
 
 module I = struct
   type 'a t = {
@@ -15,6 +15,7 @@ module I = struct
     times : ('a * 'a) Boolean.t;
     arrow : ('a * 'a) Boolean.t;
     record: (label * bool * 'a) Boolean.t;
+    chars : Chars.t;
     strs  : Strings.t;
   }
 		
@@ -24,6 +25,7 @@ module I = struct
     record= Boolean.empty;
     ints  = Intervals.empty;
     atoms = Atoms.empty;
+    chars = Chars.empty;
     strs  = Strings.empty;
   }
   let any =  {
@@ -32,6 +34,7 @@ module I = struct
     record= Boolean.full; 
     ints  = Intervals.full;
     atoms = Atoms.full;
+    chars = Chars.full;
     strs  = Strings.any;
   }
 	       
@@ -41,10 +44,13 @@ module I = struct
   let record label opt t = { empty with record = Boolean.atom (label,opt,t) }
   let atom a = { empty with atoms = Atoms.atom a }
   let string r = { empty with strs = Strings.Regexp.compile r }
+  let char c = { empty with chars = Chars.atom c }
+  let char_class c1 c2 = { empty with chars = Chars.char_class c1 c2 }
   let constant = function
     | Integer i -> interval i i
     | Atom a -> atom a
     | String s -> string (Strings.Regexp.str s)
+    | Char c -> char c
 
 		   
   let any_record = { empty with record = any.record }
@@ -56,6 +62,7 @@ module I = struct
       record= Boolean.cup x.record y.record;
       ints  = Intervals.cup x.ints  y.ints;
       atoms = Atoms.cup x.atoms y.atoms;
+      chars = Chars.cup x.chars y.chars;
       strs  = Strings.cup x.strs y.strs;
     }
       
@@ -66,6 +73,7 @@ module I = struct
       arrow = Boolean.cap x.arrow y.arrow;
       ints  = Intervals.cap x.ints  y.ints;
       atoms = Atoms.cap x.atoms y.atoms;
+      chars = Chars.cap x.chars y.chars;
       strs  = Strings.cap x.strs y.strs;
     }
       
@@ -76,6 +84,7 @@ module I = struct
       record= Boolean.diff x.record y.record;
       ints  = Intervals.diff x.ints  y.ints;
       atoms = Atoms.diff x.atoms y.atoms;
+      chars = Chars.diff x.chars y.chars;
       strs  = Strings.diff x.strs y.strs;
     }
 
@@ -84,6 +93,7 @@ module I = struct
   let equal e a b =
     if a.ints <> b.ints then raise NotEqual;
     if a.atoms <> b.atoms then raise NotEqual;
+    if a.chars <> b.chars then raise NotEqual;
     if a.strs <> b.strs then raise NotEqual;
     Boolean.equal (fun (x1,x2) (y1,y2) -> e x1 y1; e x2 y2) a.times b.times;
     Boolean.equal (fun (x1,x2) (y1,y2) -> e x1 y1; e x2 y2) a.arrow b.arrow;
@@ -97,6 +107,7 @@ module I = struct
       record= Boolean.map (fun (l,o,x) -> (l,o, f x)) a.record;
       ints  = a.ints;
       atoms = a.atoms;
+      chars = a.chars;
       strs  = a.strs;
     }
     
@@ -220,6 +231,7 @@ let rec empty_rec d =
   else if Assumptions.mem d !memo then true
   else if not (Intervals.is_empty d.ints) then false
   else if not (Atoms.is_empty d.atoms) then false
+  else if not (Chars.is_empty d.chars) then false
   else if not (Strings.is_empty d.strs) then false
   else (
     let backup = !memo in
@@ -298,6 +310,7 @@ let rec find f = function
 type t =
   | Int of int
   | Atom of atom
+  | Char of Chars.Unichar.t
   | String of string
   | Pair of t * t
   | Record of (label * t) list
@@ -311,6 +324,7 @@ let rec sample_rec memo d =
   else 
     try Int (Intervals.sample d.ints) with Not_found ->
     try Atom (Atoms.sample (gen_atom 0) d.atoms) with Not_found ->
+    try Char (Chars.sample d.chars) with Not_found ->
     try String (Strings.sample d.strs) with Not_found ->
     try sample_rec_arrow d.arrow with Not_found ->
 
@@ -604,6 +618,7 @@ struct
     if d = any then Format.fprintf ppf "Any" else
     print_union ppf 
       (Intervals.print d.ints @
+       Chars.print d.chars @
        Strings.print d.strs @
        Atoms.print "AnyAtom" print_atom d.atoms @
        Boolean.print "(Any,Any)" print_times d.times @
@@ -653,6 +668,7 @@ struct
   let rec print_sample ppf = function
     | Sample.Int i -> Format.fprintf ppf "%i" i
     | Sample.Atom a -> Format.fprintf ppf "`%s" (atom_name a)
+    | Sample.Char c -> Chars.Unichar.print ppf c
     | Sample.String s -> Format.fprintf ppf "%S" s
     | Sample.Pair (x1,x2) -> 
 	Format.fprintf ppf "(%a,%a)" 

types/types.mli

 type label = int
 type atom  = int
-type const = Integer of int | Atom of atom | String of string
+type const = Integer of int | Atom of atom | String of string | Char of Chars.Unichar.t
 
 (** Algebra **)
 
@@ -33,6 +33,8 @@ val atom     : atom -> descr
 val times    : node -> node -> descr
 val arrow    : node -> node -> descr
 val record   : label -> bool -> node -> descr
+val char     : Chars.Unichar.t -> descr
+val char_class : Chars.Unichar.t -> Chars.Unichar.t -> descr
 val string   : Strings.Regexp.regexp -> descr
 val constant : const -> descr
 
@@ -126,6 +128,7 @@ sig
   type t =
     | Int of int
     | Atom of atom
+    | Char of Chars.Unichar.t
     | String of string
     | Pair of t * t
     | Record of (label * t) list

typing/typer.ml

@@ -42,11 +42,11 @@ module StringSet = Set.Make(S)
 
 let mk' =
   let counter = ref 0 in
-  fun () ->
+  fun loc ->
     incr counter;
     let rec x = { 
       id = !counter; 
-      loc' = noloc; 
+      loc' = loc; 
       fv = None; 
       descr' = `Alias ("__dummy__", x);  
       type_node = None; 
@@ -55,8 +55,7 @@ let mk' =
     x
 
 let cons loc d =
-  let x = mk' () in
-  x.loc' <- loc;
+  let x = mk' loc in
   x.descr' <- d;
   x
     
@@ -158,14 +157,7 @@ let rec compile env { loc = loc; descr = d } : ti =
        with Not_found -> 
 	 raise_loc loc (Pattern ("Undefined type variable " ^ s))
       )
-  | Recurs (t, b) ->
-      let b = List.map (fun (v,t) -> (v,t,mk' ())) b in
-      let env = 
-	List.fold_left (fun env (v,t,x) -> StringMap.add v x env) env b in
-      List.iter 
-	(fun (v,t,x) -> x.loc' <- t.loc; x.descr' <- `Alias (v, compile env t)) 
-	b;
-      compile env t
+  | Recurs (t, b) -> compile (compile_many env b) t
   | Regexp (r,q) -> compile env (Regexp.compile r q)
   | Internal t -> cons loc (`Type t)
   | Or (t1,t2) -> cons loc (`Or (compile env t1, compile env t2))
@@ -177,6 +169,14 @@ let rec compile env { loc = loc; descr = d } : ti =
   | Constant (x,v) -> cons loc (`Constant (x,v))
   | Capture x -> cons loc (`Capture x)
 
+and compile_many env b = 
+  let b = List.map (fun (v,t) -> (v,t,mk' t.loc)) b in
+  let env = 
+    List.fold_left (fun env (v,t,x) -> StringMap.add v x env) env b in
+  List.iter (fun (v,t,x) -> x.descr' <- `Alias (v, compile env t)) b;
+  env
+
+
 let rec comp_fv seen s =
   match s.fv with
     | Some l -> l
@@ -266,16 +266,24 @@ and pat_node s : Patterns.node =
 	Patterns.define x t;
 	x
 
-let typ e =
-  let e = compile StringMap.empty e in
+let global_types = ref StringMap.empty
+
+let mk_typ e =
   if fv e = [] then type_node e 
-  else (raise_loc e.loc' 
-	  (Pattern "Capture variables are not allowed in types"))
+  else raise_loc e.loc' (Pattern "Capture variables are not allowed in types")
+    
+
+let typ e =
+  mk_typ (compile !global_types e)
 
 let pat e =
-  let e = compile StringMap.empty e in
+  let e = compile !global_types e in
   pat_node e
 
+let register_global_types b =
+  let env = compile_many !global_types b in
+  List.iter (fun (v,_) -> ignore (mk_typ (StringMap.find v env))) b;
+  global_types := env
 
 
 (* II. Build skeleton *)

typing/typer.mli

@@ -4,6 +4,9 @@ exception Constraint of Types.descr * Types.descr * string
 
 val compile_regexp : Ast.regexp -> Ast.ppat -> Ast.ppat
 
+val register_global_types : (string * Ast.ppat) list -> unit
+  (* the global environment is untouched if the function fails *)
+
 val typ : Ast.ppat -> Typed.ttyp
 val pat : Ast.ppat -> Typed.tpat