[r2005-04-03 16:50:58 by afrisch] Empty log message

Original author: afrisch
Date: 2005-04-03 16:50:59+00:00

Makefile.types

@@ -49,6 +49,8 @@ SRC= \
  cduce/runtime/value.ml \
  cduce/runtime/run_dispatch.mli \
  cduce/runtime/run_dispatch.ml \
+ cduce/runtime/explain.mli \
+ cduce/runtime/explain.ml \
  cduce/runtime/serial.mli \
  cduce/runtime/serial.ml
 

runtime/explain.ml

@@ -13,8 +13,16 @@ let rec print ppf = function
       Format.fprintf ppf 
 	"Value @[%a@] does not match type @[%a@]@."
 	Value.print v
-	Types.Print.print (Lazy.force t);
+	Types.Print.print (Lazy.force t)
 
+let print_to_string f x =
+  let b = Buffer.create 1024 in
+  let ppf = Format.formatter_of_buffer b in
+  f ppf x;
+  Buffer.contents b
+
+let to_string e =
+  print_to_string print e
 
 exception Path of t
 

runtime/explain.mli

 type t
 
 val print: Format.formatter -> t -> unit
+val to_string: t -> string
 
 val explain: Types.t -> Types.t -> Value.t -> t option
   (** [explain t0 t v] 

runtime/serial.ml

@@ -141,6 +141,13 @@ module G = struct
   let typ chunk i =
     T.get (fun x -> x) chunk.typ i
 
+  let check chunk t0 t v =
+    let t0 = typ chunk t0 and t = typ chunk t in
+    match Explain.explain t0 t v with
+    | None -> v
+    | Some p -> failwith (Explain.to_string p)
+  
+
   let record chunk i vs =
     Value.mk_record (LABA.get (fun x -> x) chunk.laba i) vs
 

runtime/serial.mli

@@ -20,6 +20,7 @@ module G : sig
   val const: chunk -> int -> Value.t
   val remove_label: chunk -> int -> Value.t -> Value.t
   val typ: chunk -> int -> Types.t
+  val check: chunk -> int -> int -> Value.t -> Value.t
   val record: chunk -> int -> Value.t array -> Value.t
   val constr: chunk -> int -> Value.t array -> Value.t
   val constr_const: chunk -> int -> Value.t

runtime/value.ml

@@ -644,6 +644,20 @@ let cduce2ocaml_int = function
   | Integer i -> Intervals.V.get_int i
   | _ -> assert false
 
+let ocaml2cduce_int32 i =
+  Integer (Intervals.V.from_int32 i)
+
+let cduce2ocaml_int32 = function
+  | Integer i -> Intervals.V.to_int32 i
+  | _ -> assert false
+
+let ocaml2cduce_int64 i =
+  Integer (Intervals.V.from_int64 i)
+
+let cduce2ocaml_int64 = function
+  | Integer i -> Intervals.V.to_int64 i
+  | _ -> assert false
+
 let ocaml2cduce_string = string_latin1
 
 let cduce2ocaml_string = get_string_latin1

runtime/value.mli

@@ -130,6 +130,10 @@ val ocaml2cduce_list : ('a -> t) -> 'a list -> t
 val cduce2ocaml_list : (t -> 'a) -> t -> 'a list
 val ocaml2cduce_constr: t -> t array -> t
 val cduce2ocaml_constr: int Atoms.map -> t -> Obj.t
+val ocaml2cduce_int32 : int32 -> t
+val cduce2ocaml_int32 : t -> int32
+val ocaml2cduce_int64 : int64 -> t
+val cduce2ocaml_int64 : t -> int64
 
 val print_utf8: U.t -> unit
 

types/intervals.ml

@@ -17,6 +17,7 @@ let check i = ()
 
 let from_int i = big_int_of_int i
 let from_bigint i = i
+  
 
 (* TODO: better serialization of bigints !!! *)
 let serialize t i = Serialize.Put.string t (string_of_big_int i)
@@ -43,6 +44,11 @@ let zero = big_int_of_int 0
 let one = big_int_of_int 1
 let minus_one = big_int_of_int (-1)
 let is_zero = equal zero
+
+let from_int32 i = mk (Int32.to_string i)
+let from_int64 i = mk (Int64.to_string i)
+let to_int32 i = Int32.of_string (to_string i)
+let to_int64 i = Int64.of_string (to_string i)
 end
 
 type interval = 
@@ -414,3 +420,6 @@ let cap i1 i2 =
   cap i1 i2
 
 *)
+
+let int32 = bounded (V.from_int32 Int32.min_int) (V.from_int32 Int32.max_int)
+let int64 = bounded (V.from_int64 Int64.min_int) (V.from_int64 Int64.max_int)

types/intervals.mli

@@ -26,6 +26,11 @@ module V : sig
   val zero : t
   val one : t
   val minus_one : t
+
+  val from_int32: Int32.t -> t
+  val from_int64: Int64.t -> t
+  val to_int32: t -> Int32.t
+  val to_int64: t -> Int64.t
 end
 
 
@@ -64,3 +69,7 @@ val sub : t -> t -> t
 val div : t -> t -> t
 val modulo : t -> t -> t
 val negat : t -> t
+
+
+val int32: t
+val int64: t

types/sequence.ml

@@ -172,3 +172,6 @@ let seq_of_list l =
   List.fold_right times' l nil_type
 
 
+let char_latin1 = Types.char (Chars.mk_classes [ (0,255) ])
+let string_latin1 = star char_latin1
+

types/sequence.mli

@@ -5,6 +5,7 @@ val nil_cst:  Types.Const.t
 val any: Types.t
 val seqseq: Types.t
 val string: Types.t
+val string_latin1: Types.t
 
 val concat: Types.t -> Types.t -> Types.t
 val flatten: Types.t -> Types.t

types_depend

@@ -169,32 +169,28 @@ cduce/runtime/run_dispatch.cmx: cduce/runtime/value.cmx cduce/types/types.cmx \
     string.cmx cduce/types/patterns.cmx cduce/types/ident.cmx format.cmx \
     cduce/misc/encodings.cmx cduce/types/chars.cmx cduce/types/atoms.cmx \
     array.cmx cduce/runtime/run_dispatch.cmi 
+cduce/runtime/explain.cmi: cduce/runtime/value.cmi cduce/types/types.cmi \
+    format.cmi 
+cduce/runtime/explain.cmo: cduce/runtime/value.cmi cduce/types/types.cmi \
+    cduce/runtime/run_dispatch.cmi cduce/types/patterns.cmi list.cmi lazy.cmi \
+    cduce/types/ident.cmo format.cmi cduce/misc/encodings.cmi \
+    cduce/types/chars.cmi buffer.cmi cduce/types/atoms.cmi array.cmi \
+    cduce/runtime/explain.cmi 
+cduce/runtime/explain.cmx: cduce/runtime/value.cmx cduce/types/types.cmx \
+    cduce/runtime/run_dispatch.cmx cduce/types/patterns.cmx list.cmx lazy.cmx \
+    cduce/types/ident.cmx format.cmx cduce/misc/encodings.cmx \
+    cduce/types/chars.cmx buffer.cmx cduce/types/atoms.cmx array.cmx \
+    cduce/runtime/explain.cmi 
 cduce/runtime/serial.cmi: cduce/runtime/value.cmi cduce/types/types.cmi \
     cduce/types/patterns.cmi obj.cmi cduce/types/ident.cmo \
     cduce/types/atoms.cmi 
 cduce/runtime/serial.cmo: cduce/runtime/value.cmi cduce/types/types.cmi \
     cduce/misc/serialize.cmi cduce/runtime/run_dispatch.cmi \
     cduce/types/patterns.cmi list.cmi cduce/types/ident.cmo \
-    cduce/misc/encodings.cmi cduce/misc/custom.cmo cduce/types/atoms.cmi \
-    array.cmi cduce/runtime/serial.cmi 
+    cduce/runtime/explain.cmi cduce/misc/encodings.cmi cduce/misc/custom.cmo \
+    cduce/types/atoms.cmi array.cmi cduce/runtime/serial.cmi 
 cduce/runtime/serial.cmx: cduce/runtime/value.cmx cduce/types/types.cmx \
     cduce/misc/serialize.cmx cduce/runtime/run_dispatch.cmx \
     cduce/types/patterns.cmx list.cmx cduce/types/ident.cmx \
-    cduce/misc/encodings.cmx cduce/misc/custom.cmx cduce/types/atoms.cmx \
-    array.cmx cduce/runtime/serial.cmi 
-cduce/runtime/xml_loader.cmi: cduce/runtime/value.cmi 
-cduce/runtime/xml_loader.cmo: cduce/runtime/value.cmi string.cmi \
-    cduce/misc/ns.cmi list.cmi cduce/types/ident.cmo cduce/misc/encodings.cmi \
-    cduce/types/atoms.cmi cduce/runtime/xml_loader.cmi 
-cduce/runtime/xml_loader.cmx: cduce/runtime/value.cmx string.cmx \
-    cduce/misc/ns.cmx list.cmx cduce/types/ident.cmx cduce/misc/encodings.cmx \
-    cduce/types/atoms.cmx cduce/runtime/xml_loader.cmi 
-cduce/runtime/xml_printer.cmi: cduce/runtime/value.cmi cduce/misc/ns.cmi 
-cduce/runtime/xml_printer.cmo: cduce/runtime/value.cmi \
-    cduce/types/sequence.cmi cduce/misc/ns.cmi list.cmi cduce/types/ident.cmo \
-    cduce/misc/encodings.cmi cduce/types/atoms.cmi \
-    cduce/runtime/xml_printer.cmi 
-cduce/runtime/xml_printer.cmx: cduce/runtime/value.cmx \
-    cduce/types/sequence.cmx cduce/misc/ns.cmx list.cmx cduce/types/ident.cmx \
-    cduce/misc/encodings.cmx cduce/types/atoms.cmx \
-    cduce/runtime/xml_printer.cmi 
+    cduce/runtime/explain.cmx cduce/misc/encodings.cmx cduce/misc/custom.cmx \
+    cduce/types/atoms.cmx array.cmx cduce/runtime/serial.cmi