[r2005-03-31 14:54:09 by afrisch] Empty log message

Original author: afrisch
Date: 2005-03-31 14:54:10+00:00

Makefile.types

@@ -102,8 +102,8 @@ cduce/cat1:
 
 
 .PHONY: compute_depend
-cduce/compute_depend:
-	ocamldep $(INCLUDES) $(SRC) > cduce/types_depend
+compute_depend:
+	ocamldep $(CDUCE_INCLUDES) $(SRC) > cduce/types_depend
 
 include cduce/types_depend
 

runtime/serial.ml

@@ -38,6 +38,7 @@ module CONST = Mk(Types.Const)
 module LAB = Mk(Ident.LabelPool)
 module T = Mk(Types)
 module LABA = Mk(Custom.Array(Ident.LabelPool))
+module TAG = Mk(Atoms.V)
 
 module P = struct
   type chunk =
@@ -46,6 +47,7 @@ module P = struct
 	lab : LAB.pchunk;
 	typ : T.pchunk;
  	laba : LABA.pchunk;
+	tag : TAG.pchunk;
      }
 
   let init () = 
@@ -54,6 +56,7 @@ module P = struct
       lab = LAB.init ();
       typ = T.init ();
       laba = LABA.init ();
+      tag = TAG.init ();
     }
 
   let serialize s c =
@@ -61,13 +64,15 @@ module P = struct
     CONST.serialize s c.cst;
     LAB.serialize s c.lab;
     T.serialize s c.typ;
-    LABA.serialize s c.laba
+    LABA.serialize s c.laba;
+    TAG.serialize s c.tag
 
   let pm c = PM.put c.pm
   let const c = CONST.put c.cst
   let label c = LAB.put c.lab
   let typ c = T.put c.typ
   let label_array c = LABA.put c.laba
+  let tag c = TAG.put c.tag
 
   let mk c =
     let s = Serialize.Put.run serialize c in
@@ -85,6 +90,7 @@ module G = struct
 	lab : Ident.label LAB.chunk;
 	typ : Types.t T.chunk;
 	laba : Ident.label array LABA.chunk;
+	tag : Value.t TAG.chunk;
       }
 
   let deserialize s =
@@ -93,7 +99,8 @@ module G = struct
     let lab = LAB.deserialize s in
     let typ = T.deserialize s in
     let laba = LABA.deserialize s in
-    { pm = pm; cst = cst; lab = lab; typ = typ; laba = laba }
+    let tag = TAG.deserialize s in
+    { pm = pm; cst = cst; lab = lab; typ = typ; laba = laba; tag = tag }
 
   let mk s = 
     Types.clear_deserialize_table ();
@@ -127,5 +134,8 @@ module G = struct
 
   let record chunk i vs =
     Value.mk_record (LABA.get (fun x -> x) chunk.laba i) vs
+
+  let constr chunk i vs =
+    Value.ocaml2cduce_constr (TAG.get (fun x -> Value.Atom x) chunk.tag i) vs
 end
 

runtime/serial.mli

@@ -8,6 +8,7 @@ module P : sig
   val label: chunk -> Ident.label -> int
   val typ: chunk -> Types.t -> int
   val label_array: chunk -> Ident.label array -> int
+  val tag: chunk -> Atoms.V.t -> int
 end
 
 module G : sig
@@ -19,6 +20,7 @@ module G : sig
   val remove_label: chunk -> int -> Value.t -> Value.t
   val typ: chunk -> int -> Types.t
   val record: chunk -> int -> Value.t array -> Value.t
+  val constr: chunk -> int -> Value.t array -> Value.t
 end
 
 

runtime/value.ml

@@ -58,6 +58,12 @@ let rec sequence_rev accu = function
 
 let sequence_rev l = sequence_rev nil l
 
+let sequence_of_array a =
+  let rec aux accu i =
+    if (i = 0) then accu
+    else let i = pred i in aux (Pair (a.(i), accu)) i in
+  aux nil (Array.length a)
+
 let concat v1 v2 = 
   match (v1,v2) with
     | (Atom _, v) | (v, Atom _) -> v
@@ -698,6 +704,10 @@ let div v1 v2 = match (v1,v2) with
   | (Integer x, Integer y) -> Integer (Intervals.V.div x y)
   | _ -> assert false
 
+let modulo v1 v2 = match (v1,v2) with
+  | (Integer x, Integer y) -> Integer (Intervals.V.modulo x y)
+  | _ -> assert false
+
 
 let pair v1 v2 = Pair (v1,v2)
 let xml v1 v2 v3 = Xml (v1,v2,v3)
@@ -747,3 +757,11 @@ let xtransform f v = xtransform_aux f nil v
 let remove_field l = function
   | Record r -> Record (LabelMap.remove l r)
   | _ -> assert false
+
+let rec ocaml2cduce_list f = function
+  | [] -> nil
+  | hd::tl -> Pair (f hd, ocaml2cduce_list f tl)
+
+let no_attr = Record LabelMap.empty
+
+let ocaml2cduce_constr tag va = Xml (tag, no_attr, sequence_of_array va)

runtime/value.mli

@@ -126,6 +126,8 @@ val ocaml2cduce_option: ('a -> t) -> 'a option -> t
 val cduce2ocaml_option: (t -> 'a) -> t -> 'a option
 val ocaml2cduce_wchar : int -> t
 val ocaml2cduce_atom : U.t -> U.t -> t
+val ocaml2cduce_list : ('a -> t) -> 'a list -> t
+val ocaml2cduce_constr: t -> t array -> t
 
 val print_utf8: U.t -> unit
 
@@ -134,6 +136,7 @@ val add: t -> t -> t
 val sub: t -> t -> t
 val mul: t -> t -> t
 val div: t -> t -> t
+val modulo: t -> t -> t
 val pair: t -> t -> t
 val xml: t -> t -> t -> t
 val mk_record: label array -> t array -> t
@@ -141,3 +144,5 @@ val mk_record: label array -> t array -> t
 val transform: (t -> t) -> t -> t
 val xtransform: (t -> t) -> t -> t
 val remove_field: label -> t -> t
+
+

types/intervals.ml

@@ -34,6 +34,7 @@ let div = div_big_int
 let modulo  = mod_big_int
 let succ = succ_big_int
 let pred = pred_big_int
+let negat t = sub_big_int zero_big_int t
 
 let lt = lt_big_int
 let gt = gt_big_int
@@ -383,6 +384,9 @@ let mul l1 l2 =
     ) empty l1
 
 
+let div i1 i2 = any
+let modulo i1 i2 = any
+
 let dmp s i =
   let ppf = Format.std_formatter in
   Format.fprintf ppf "%s = [ " s;

types/intervals.mli

@@ -18,6 +18,7 @@ module V : sig
   val modulo: t -> t -> t
   val succ: t -> t
   val pred: t -> t
+  val negat: t -> t
 
   val lt: t -> t -> bool
   val gt: t -> t -> bool
@@ -60,4 +61,6 @@ val single : t -> V.t
 val add : t -> t -> t
 val mul : t -> t -> t
 val sub : t -> t -> t
+val div : t -> t -> t
+val modulo : t -> t -> t
 val negat : t -> t