[r2005-03-24 19:33:55 by afrisch] Empty log message

Original author: afrisch
Date: 2005-03-24 19:33:56+00:00

Makefile.types

@@ -57,22 +57,33 @@ ML_SRC=$(filter %.ml,$(SRC))
 CDUCE_OBJECTS=$(ML_SRC:.ml=.cmo)
 
 $(CDUCE_OBJECTS) $(CDUCE_OBJECTS:.cmo=.cmi): $(COMPILER)
-
+$(CDUCE_OBJECTS:.cmo=.cmx): $(OPTCOMPILER)
 
 cduce_types.cmo: $(CDUCE_OBJECTS)
 	$(CAMLC) $(COMPFLAGS) -pack -o cduce_types.cmo $(CDUCE_INCLUDES) $^
 
+cduce_types.cmx: $(CDUCE_OBJECTS:.cmo=.cmx)
+	$(CAMLOPT) $(OPTCOMPFLAGS) -pack -o cduce_types.cmx $(CDUCE_INCLUDES) $^
+cduce_types.p.cmx: cduce_types.cmx
+	cp cduce_types.cmx cduce_types.p.cmx
+	cp cduce_types.o cduce_types.p.o
+
 CDUCE_INCLUDES = $(DIRS:%=-I %)
 
 
 cduce/types/intervals.cmo: cduce/types/intervals.ml cduce/cat1 cduce/types/intervals_int.ml
 	$(CAMLC) $(COMPFLAGS) -c $(CDUCE_INCLUDES) -pp 'cduce/cat1 cduce/types/intervals_int.ml' $<
 
+cduce/types/intervals.cmx: cduce/types/intervals.ml cduce/cat1 cduce/types/intervals_int.ml
+	$(CAMLOPT) $(OPTCOMPFLAGS) -c $(CDUCE_INCLUDES) -pp 'cduce/cat1 cduce/types/intervals_int.ml' $<
+
 cduce/types/intervals.cmi: cduce/types/intervals.mli cduce/cat1 cduce/types/intervals_int.mli
 	$(CAMLC) $(COMPFLAGS) -c $(CDUCE_INCLUDES) -pp 'cduce/cat1 cduce/types/intervals_int.mli' $<
 
 cduce/misc/stats.cmo: cduce/misc/stats.ml
 	$(CAMLC) $(COMPFLAGS) -c $(CDUCE_INCLUDES) -pp 'sed s/Unix\\.gettimeofday\(\)/0./' $<
+cduce/misc/stats.cmx: cduce/misc/stats.ml
+	$(CAMLOPT) $(OPTCOMPFLAGS) -c $(CDUCE_INCLUDES) -pp 'sed s/Unix\\.gettimeofday\(\)/0./' $<
 
 cduce/cat1:
 	echo "cat \$$1" > cduce/cat1
@@ -84,7 +95,7 @@ cduce/cat1:
 	$(CAMLC) $(COMPFLAGS) -c $(CDUCE_INCLUDES) $<
 
 .ml.cmx:
-	$(CAMLOPT) -c $(CDUCE_INCLUDES) $<
+	$(CAMLOPT) $(OPTCOMPFLAGS) -c $(CDUCE_INCLUDES) $<
 
 .mli.cmi:
 	$(CAMLC) $(COMPFLAGS) -c $(CDUCE_INCLUDES) $<

parser/ast.ml

@@ -95,10 +95,6 @@ and branches = (ppat * pexpr) list
 and ppat = ppat' located
 and ppat' =
   | PatVar of (U.t option) * U.t  (* optional compilation unit *)
-(*
-  | SchemaVar of  (* type/pattern schema variable *)
-      Schema_types.component_kind * U.t * U.t (* kind, schema, name *)
-*)
   | Cst of pexpr
   | NsT of U.t
   | Recurs of ppat * (Location.loc * U.t * ppat) list

runtime/serial.ml

@@ -31,18 +31,22 @@ end
 
 module PM = Mk(Custom.Pair(Types)(Custom.List(Patterns.Node)))
 module CONST = Mk(Types.Const)
+module LAB = Mk(Ident.LabelPool)
 
 module P = struct
   let init () = 
     PM.init ();
-    CONST.init ()
+    CONST.init ();
+    LAB.init ()
 
   let serialize s () =
     PM.serialize s;
-    CONST.serialize s
+    CONST.serialize s;
+    LAB.serialize s
 
   let pm = PM.put
   let const = CONST.put
+  let label = LAB.put
 
   let mk () =
     let s = Serialize.Put.run serialize () in
@@ -57,12 +61,14 @@ module G = struct
 	  (Patterns.Compile.dispatcher * int Patterns.Compile.rhs array)
 	  PM.chunk;
 	cst : Value.t CONST.chunk;
+	lab : Ident.label LAB.chunk;
       }
 
   let deserialize s =
     let pm = PM.deserialize s in
     let cst = CONST.deserialize s in
-    { pm = pm; cst = cst }
+    let lab = LAB.deserialize s in
+    { pm = pm; cst = cst; lab = lab }
 
   let mk s = 
     Types.clear_deserialize_table ();
@@ -88,5 +94,7 @@ module G = struct
   let const chunk i =
     CONST.get Value.const chunk.cst i
 	  
+  let remove_label chunk i v =
+    Value.remove_field (LAB.get (fun x -> x) chunk.lab i) v
 end
 

runtime/serial.mli

@@ -4,6 +4,7 @@ module P : sig
 
   val pm: Types.t * Patterns.Node.t list -> int
   val const: Types.const -> int
+  val label: Ident.label -> int
 end
 
 module G : sig
@@ -12,6 +13,7 @@ module G : sig
 
   val pm: chunk -> int -> Value.t -> int * Value.t array
   val const: chunk -> int -> Value.t
+  val remove_label: chunk -> int -> Value.t -> Value.t
 end
 
 

runtime/value.ml

@@ -732,3 +732,6 @@ let rec xtransform_aux f accu = function
 
 let xtransform f v = xtransform_aux f nil v
 
+let remove_field l = function
+  | Record r -> Record (LabelMap.remove l r)
+  | _ -> assert false

runtime/value.mli

@@ -137,3 +137,4 @@ val mk_record: (U.t * U.t) array -> t array -> t
 
 val transform: (t -> t) -> t -> t
 val xtransform: (t -> t) -> t -> t
+val remove_field: label -> t -> t

typing/typer.ml

@@ -1542,7 +1542,7 @@ and type_check' loc env e constr precise = match e with
   | Dot (e,l) ->
       let t = type_check env e Types.Record.any true in
       let t = 
-        try (Types.Record.project t l) 
+        try Types.Record.project t l
         with Not_found -> raise_loc loc (WrongLabel(t,l))
       in
       verify loc t constr