[r2002-10-26 20:45:22 by cvscast] Empty log message

Original author: cvscast
Date: 2002-10-26 20:45:22+00:00

depend

@@ -3,14 +3,16 @@ 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 types/atoms.cmi types/chars.cmi \
-    parser/lexer.cmo parser/location.cmi types/sequence.cmi types/types.cmi \
-    parser/parser.cmi 
+    types/intervals.cmi parser/lexer.cmo parser/location.cmi \
+    types/sequence.cmi types/types.cmi parser/parser.cmi 
 parser/parser.cmx: parser/ast.cmx types/atoms.cmx types/chars.cmx \
-    parser/lexer.cmx parser/location.cmx types/sequence.cmx types/types.cmx \
-    parser/parser.cmi 
+    types/intervals.cmx parser/lexer.cmx parser/location.cmx \
+    types/sequence.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 
+typing/typed.cmo: parser/location.cmi types/patterns.cmi types/sortedMap.cmi \
+    types/types.cmi 
+typing/typed.cmx: parser/location.cmx types/patterns.cmx types/sortedMap.cmx \
+    types/types.cmx 
 typing/typer.cmo: parser/ast.cmo types/intervals.cmi parser/location.cmi \
     types/patterns.cmi types/sequence.cmi types/sortedList.cmi \
     typing/typed.cmo types/types.cmi typing/typer.cmi 
@@ -59,12 +61,14 @@ types/sortedMap.cmi: types/sortedList.cmi
 types/syntax.cmi: types/patterns.cmi types/types.cmi 
 types/types.cmi: types/atoms.cmi types/chars.cmi types/intervals.cmi \
     types/sortedMap.cmi 
-runtime/value.cmi: types/chars.cmi typing/typed.cmo types/types.cmi 
-runtime/value.cmo: types/chars.cmi typing/typed.cmo types/types.cmi \
-    runtime/value.cmi 
-runtime/value.cmx: types/chars.cmx typing/typed.cmx types/types.cmx \
-    runtime/value.cmi 
+runtime/value.cmi: types/patterns.cmi typing/typed.cmo 
+runtime/value.cmo: types/chars.cmi types/patterns.cmi types/sequence.cmi \
+    types/sortedMap.cmi typing/typed.cmo types/types.cmi runtime/value.cmi 
+runtime/value.cmx: types/chars.cmx types/patterns.cmx types/sequence.cmx \
+    types/sortedMap.cmx typing/typed.cmx types/types.cmx runtime/value.cmi 
 driver/cduce.cmo: parser/ast.cmo types/builtin.cmo parser/location.cmi \
-    parser/parser.cmi types/patterns.cmi typing/typer.cmi types/types.cmi 
+    parser/parser.cmi types/patterns.cmi typing/typer.cmi types/types.cmi \
+    runtime/value.cmi 
 driver/cduce.cmx: parser/ast.cmx types/builtin.cmx parser/location.cmx \
-    parser/parser.cmx types/patterns.cmx typing/typer.cmx types/types.cmx 
+    parser/parser.cmx types/patterns.cmx typing/typer.cmx types/types.cmx \
+    runtime/value.cmx 

driver/cduce.ml

@@ -100,7 +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;
 	let v = Value.eval Value.empty_env e in
-	Format.fprintf ppf "=> %a@\n" Value.print v
+	Format.fprintf ppf "=> @[%a@]@\n" Value.print v
     | Ast.TypeDecl _ -> ()
     | Ast.Debug l -> debug l
     | _ -> assert false

parser/parser.ml

@@ -67,10 +67,6 @@ EXTEND
         mk loc (Match (e1,[p,e2]))
     ]
 
-    |
-    [ LIDENT "flatten"; e = expr -> mk loc (Op ("flatten",[e]))
-    | e1 = expr; e2 = expr -> mk loc (Apply (e1,e2))
-    ]
     
     | 
     [ e1 = expr; op = ["+" | "-" | "@"]; e2 = expr -> mk loc (Op (op,[e1;e2]))
@@ -82,6 +78,11 @@ EXTEND
     [ e = expr;  "."; l = [LIDENT | UIDENT] -> mk loc (Dot (e,Types.label l)) 
     ]  
  
+    |
+    [ LIDENT "flatten"; e = expr -> mk loc (Op ("flatten",[e]))
+    | e1 = expr; e2 = expr -> mk loc (Apply (e1,e2))
+    ]
+
     | "no_appl" 
     [ c = const -> mk loc (Cst c)
     | "("; l = LIST1 expr SEP ","; ")" -> tuple loc l
@@ -185,7 +186,16 @@ EXTEND
       | i = INT ; "--"; j = INT -> 
           let i = Big_int.big_int_of_string i 
 	  and j = Big_int.big_int_of_string j in
-          mk loc (Internal (Types.interval i j))
+          mk loc (Internal (Types.interval (Intervals.bounded i j)))
+      | i = INT -> 
+          let i = Big_int.big_int_of_string i  in
+          mk loc (Internal (Types.interval (Intervals.atom i)))
+      | "*--"; j = INT ->
+	  let j = Big_int.big_int_of_string j in
+          mk loc (Internal (Types.interval (Intervals.left j)))
+      | i = INT; "--*" ->
+	  let i = Big_int.big_int_of_string i in
+          mk loc (Internal (Types.interval (Intervals.right i)))
       | i = char ->
           mk loc (Internal (Types.char (Chars.char_class i i)))
       | i = char ; "--"; j = char ->

runtime/value.ml

@@ -15,24 +15,60 @@ and abstr = {
   fun_body  : Typed.branches;
 }
 
-let rec print ppf = function
-  | Pair (x,y) ->
-      Format.fprintf ppf "(%a,%a)" print x print y
-  | Record l ->
-      Format.fprintf ppf "{%a}" print_record l
-  | Atom a ->
-      Format.fprintf ppf "`%s" (Types.atom_name a)
-  | Integer i ->
-      Format.fprintf ppf "%s" (Big_int.string_of_big_int i)
-  | Char c ->
-      Chars.Unichar.print ppf c
-  | Fun c ->
-      Format.fprintf ppf "<fun>"
+let rec is_seq = function
+  | Pair (_, y) when is_seq y -> true
+  | Atom a when a = Sequence.nil_atom -> true
+  | _ -> false
+
+let is_xml = function
+  | Pair (Atom _, Pair (Record _, s)) when is_seq s -> true
+  | _ -> false
+
+let rec is_str = function
+  | Pair (Char _, y) when is_str y -> true
+  | Atom a when a = Sequence.nil_atom -> true
+  | _ -> false
+
+let rec print ppf v =
+  if is_str v then Format.fprintf ppf "\"%a\"" print_quoted_str v
+  else if is_xml v then print_xml ppf v
+  else if is_seq v then Format.fprintf ppf "[ %a]" print_seq v
+  else match v with
+    | Pair (x,y) -> Format.fprintf ppf "(%a,%a)" print x print y
+    | Record l -> Format.fprintf ppf "{%a }" print_record l
+    | Atom a ->	Format.fprintf ppf "`%s" (Types.atom_name a)
+    | Integer i -> Format.fprintf ppf "%s" (Big_int.string_of_big_int i)
+    | Char c ->	Chars.Unichar.print ppf c
+    | Fun c -> Format.fprintf ppf "<fun>"
+and print_quoted_str ppf = function
+  | Pair (Char c, y) -> 
+      Chars.Unichar.print_in_string ppf c; 
+      print_quoted_str ppf y
+  | _ -> ()
+and print_seq ppf = function
+  | Pair (Char _, _) as s -> Format.fprintf ppf "'%a" print_str s
+  | Pair (x,y) -> Format.fprintf ppf "@[%a@]@ %a" print x print_seq y
+  | _ -> ()
+and print_str ppf = function
+  | Pair (Char c,y) ->
+      Chars.Unichar.print_in_string ppf c; 
+      print_str ppf y
+  | v ->
+      Format.fprintf ppf "\' ";
+      print_seq ppf v
+
+and print_xml ppf = function
+  | Pair(Atom tag, Pair (Record attr,content)) ->
+      Format.fprintf ppf "@[<hv2><%s%a>[@ %a@]]" 
+      (Types.atom_name tag)
+      print_record attr
+      print_seq content
+  | _ -> assert false
 
 and print_record ppf = function
   | [] -> ()
-  | [f] -> print_field ppf f
-  | f :: rem -> Format.fprintf ppf "%a; %a" print_field f print_record rem
+  | [f] -> Format.fprintf ppf " %a" print_field f
+  | f :: rem -> Format.fprintf ppf " %a;%a" print_field f print_record rem
 
 and print_field ppf (l,v) = 
   Format.fprintf ppf "%s = %a" (Types.label_name l) print v  
@@ -144,11 +180,10 @@ and run_disp_field v bindings fields l vl = function
 (* Evaluation of expressions *)
 
 
-let rec eval env e = 
-  match e.Typed.exp_descr with
+let rec eval env e0 = 
+  match e0.Typed.exp_descr with
     | Typed.Var s -> Env.find s env
-    | Typed.Apply (f,arg) ->
-	eval_apply (eval env f) (eval env arg)
+    | Typed.Apply (f,arg) ->  eval_apply (eval env f) (eval env arg)
     | Typed.Abstraction a ->
 	let a' = { 
 	  fun_env = env;
@@ -160,8 +195,7 @@ let rec eval env e =
 	   | Some f -> a'.fun_env <- Env.add f self a'.fun_env
 	   | None -> ());
 	self
-    | Typed.RecordLitt r ->
-	Record (List.map (fun (l,e) -> (l, eval env e)) r)
+    | Typed.RecordLitt r -> Record (List.map (fun (l,e) -> (l, eval env e)) r)
     | Typed.Pair (e1,e2) -> Pair (eval env e1, eval env e2)
     | Typed.Cst c -> const c
     | Typed.Match (arg,brs) -> eval_branches env brs (eval env arg)

tests/addrbook.cd

@@ -4,7 +4,7 @@ type Name = <name>[String];;
 type Addr = <addr>[String];;
 type Tel = <tel>[String];;
 
-(*
+
 <addrbook>[
   <name>["Haruo Hosoya"]
   <addr>["Tokyo"]
@@ -41,7 +41,7 @@ type Tel = <tel>[String];;
   <name>["Peter Buneman"]
   <addr>["Scotland"]
  ];;
-*)
+
 
 (*
 

types/boolean.ml

@@ -19,6 +19,19 @@ let cup t s =
       List.filter (fun (p,n) -> not (List.exists (may_remove (p,n)) s)) t in 
     SortedList.cup s t
 
+let clean t =
+  let rec aux accu = function
+    | (p,n) :: rem ->
+	if (List.exists (may_remove (p,n)) accu)
+	  || (List.exists (may_remove (p,n)) rem)
+	then aux accu rem
+	else aux((p,n) :: accu) rem 
+    | [] -> accu 
+  in
+  List.rev (aux [] t)
+
+    
+
 let rec fold2_aux f a x = function
   | [] -> x
   | h :: t -> fold2_aux f a (f x a h) t
@@ -45,7 +58,7 @@ let cap s t =
         lines1
 	lines2
     in
-    SortedList.cup common (SortedList.from_list lines)
+    clean (SortedList.cup common (SortedList.from_list lines))
 
 let diff c1 c2 =
   if c2 == full then empty

types/chars.ml

@@ -17,6 +17,9 @@ module Unichar = struct
     if (c < 128) 
     then Format.fprintf ppf "%C" (Char.chr c)
     else Format.fprintf ppf "#x%x" c
+
+  let print_in_string ppf c =
+    Format.fprintf ppf "%c" (Char.chr c)
 end
 
 type t = (Unichar.t * Unichar.t) list

types/chars.mli

@@ -5,6 +5,7 @@ module Unichar : sig
   val to_int: t -> int
 
   val print : Format.formatter -> t -> unit
+  val print_in_string : Format.formatter -> t -> unit
 end
 
 type t = (Unichar.t * Unichar.t) list

types/intervals.ml

@@ -38,9 +38,13 @@ let hash = function
 let empty = []
 let any = [Any]
 
-let atom a b =
+let bounded a b =
   if le_big_int a b then [Bounded (a,b)] else empty
 
+let left a = [Left a]
+let right a = [Right a]
+let atom a = bounded a a
+
 
 let rec iadd_left l b = match l with
   | [] -> [Left b]

types/intervals.mli

@@ -9,7 +9,10 @@ val cup   : t -> t -> t
 val cap   : t -> t -> t
 val diff  : t -> t -> t
 
-val atom  : Big_int.big_int -> Big_int.big_int -> t
+val bounded  : Big_int.big_int -> Big_int.big_int -> t
+val left : Big_int.big_int -> t
+val right : Big_int.big_int -> t
+val atom : Big_int.big_int -> t
 
 
 val is_empty : t -> bool

types/patterns.ml

@@ -451,6 +451,7 @@ struct
 	    let p = pl.(i) in
 	    let tp = p.Normal.na in
 	    let v = p.Normal.nfv in
+(*	    let tp = Types.normalize tp in *)
 	    `Switch 
 	      (num arity v,
 	       aux (Types.cap t tp) (arity + (List.length v)) (i+1),
@@ -565,6 +566,7 @@ struct
 		) yes;
       unselect.(i) <- no @ unselect.(i) in
     Array.iteri (fun i -> List.iter (aux i)) pl;
+
     let sorted = Array.of_list (SortedMap.from_list SortedList.cup !accu) in
     let infos = Array.map snd sorted in
     let disp = dispatcher t (Array.map fst sorted) in
@@ -574,6 +576,7 @@ struct
       List.iter (fun (j,r) -> List.iter (add r) infos.(j)) m;
       d t selected unselect
     in
+
     let res = Array.map result disp.codes in
     post (disp,res)
 
@@ -585,7 +588,7 @@ struct
 	   let t = Types.diff t (p.Normal.a) in
 	   (t, (p,e) :: brs)
 	) (t,[]) brs in
-	   
+	
     let pl = Array.map (fun x -> [x]) (Array.of_list brs) in
     get_tests 
       pl 

types/types.ml

@@ -36,14 +36,14 @@ module I = struct
     chars = Chars.any;
   }
 	       
-  let interval i j = { empty with ints = Intervals.atom i j }
+  let interval i = { empty with ints = i }
   let times x y = { empty with times = Boolean.atom (x,y) }
   let arrow x y = { empty with arrow = Boolean.atom (x,y) }
   let record label opt t = { empty with record = Boolean.atom (label,opt,t) }
   let atom a = { empty with atoms = a }
   let char c = { empty with chars = c }
   let constant = function
-    | Integer i -> interval i i
+    | Integer i -> interval (Intervals.atom i)
     | Atom a -> atom (Atoms.atom a)
     | Char c -> char (Chars.atom c)
 

types/types.mli

@@ -33,7 +33,7 @@ val any    : descr
 
 (** Constructors **)
 
-val interval : Big_int.big_int -> Big_int.big_int -> descr
+val interval : Intervals.t -> descr
 val atom     : atom Atoms.t -> descr
 val times    : node -> node -> descr
 val arrow    : node -> node -> descr