clean up

CHANGES

-Since 0.5.6
-   * Allow reference to named OCaml types (by Pietro Abate)
-
-
 0.5.0
    * Port to OCaml 3.10, with the help of Nicolas Pouillard
 

ocamliface/.cvsignore

@@ -4,5 +4,4 @@
 *.cma
 *.cmxa
 cmi2ml
-asttypes.ml
-ocaml_files
+asttypes.ml
\ No newline at end of file

ocamliface/mlstub.ml

@@ -684,8 +684,6 @@ let to_cd_dyn = function
 let register () =
   Typer.has_ocaml_unit :=
     (fun cu -> Mltypes.has_cmi (U.get_str cu));
-  Typer.cduce_conv :=
-    (fun v -> typ_descr (Mltypes.find_type v).def);
   Librarian.stub_ml := stub_ml;
   Externals.register := register;
   Externals.ext_info := (fun () -> Obj.magic !exts);

ocamliface/mltypes.ml

@@ -223,14 +223,6 @@ let unfold ty =
   vars := [];
   (t,n)
 
-let unfold_type p =
-  vars := [];
-  Hashtbl.clear constr_table;
-  let t = unfold_constr { seen = IntSet.empty; constrs = StringSet.empty;
-			  vars = IntMap.empty } p [] in
-  assert (!vars = []);
-  t
-
 (* Reading .cmi *)
 
 let unsupported s =
@@ -241,7 +233,6 @@ let has_cmi name =
   try ignore (Misc.find_in_path_uncap !Config.load_path (name ^ ".cmi")); true
   with Not_found -> false
 
-(* find the cduce type associated to an ocaml value *)
 let find_value v =
   Config.load_path := Config.standard_library :: !Loc.obj_path;
   let li = Longident.parse v in
@@ -249,14 +240,6 @@ let find_value v =
   let (_,vd) = Env.lookup_value li Env.initial in
   unfold vd.val_type
 
-(* find the cduce type associated to an ocaml type *)
-let find_type t =
-  Config.load_path := Config.standard_library :: !Loc.obj_path;
-  let li = Longident.parse t in
-  ocaml_env := Env.initial;
-  let (p,_) = Env.lookup_type li Env.initial in
-  unfold_type p
-
 let values_of_sig name sg =
   List.fold_left
     (fun accu v -> match v with

ocamliface/mltypes.mli

@@ -31,4 +31,4 @@ val print_ocaml : Format.formatter -> Types.type_expr -> unit
 
 
 val find_value: string -> t * int
-val find_type : string -> t
+

runtime/print_xml.ml

@@ -66,9 +66,13 @@ let false_literal = U.mk "false"
 
   (* @raise exn_print_xml in case of failure. Rationale: schema printing is
    * the last attempt to print a value, others have already failed *)
-let rec schema_value ?(recurs=true) ~wds v = match v with
-  | Abstract ("float",f) ->
-      wds (U.mk (string_of_float (Obj.magic f : float)))
+let rec schema_value ?(recurs=true) ~wds ~wcs v = match v with
+  | Abstract ("float",o) ->
+      wds (U.mk (string_of_float (Obj.magic o : float)))
+  | Abstract ("cdata",o) ->
+      wcs (U.mk "<![CDATA[");
+      wcs (U.mk (U.get_str (Obj.magic o : U.t)));
+      wcs (U.mk "]]>")
   | Record _ as v ->
       (try
         wds (Schema_builtin.string_of_time_type (Value.get_fields v))
@@ -76,18 +80,18 @@ let rec schema_value ?(recurs=true) ~wds v = match v with
   | Integer i -> wds (U.mk (Intervals.V.to_string i))
   | v when Value.equal v Value.vtrue -> wds true_literal
   | v when Value.equal v Value.vfalse -> wds false_literal
-  | Pair _ as v when recurs -> schema_values ~wds v
+  | Pair _ as v when recurs -> schema_values ~wds ~wcs v
   | String_utf8 _ | String_latin1 _ as v -> wds (fst (get_string_utf8 v))
   | _ -> raise exn_print_xml
 
-and schema_values ~wds v =
+and schema_values ~wds ~wcs v =
   match v with
   | Pair (hd, Atom a) when a = Sequence.nil_atom ->
-      schema_value ~recurs:false ~wds hd
+      schema_value ~recurs:false ~wds ~wcs hd
   | Pair (hd, tl) ->
-      schema_value ~recurs:false ~wds hd;
+      schema_value ~recurs:false ~wds ~wcs hd;
       wds blank;
-      schema_values ~wds tl
+      schema_values ~wds ~wcs tl
   | _ -> raise exn_print_xml
 
 let to_buf ~utf8 buffer ns_table v = 
@@ -97,6 +101,7 @@ let to_buf ~utf8 buffer ns_table v =
 
   let wms = write_markup_string ~to_enc buffer
   and wds s = write_data_string ~to_enc buffer (U.get_str s)
+  and wcs s = buffer (U.get_str s) in
   in
   let write_att (n,v) =
     wms (" " ^ (Ns.Printer.attr printer (Label.value n)) ^ "=\""); wds v; wms "\"" in
@@ -160,7 +165,7 @@ let to_buf ~utf8 buffer ns_table v =
                          end else begin
                            let buf = Buffer.create 20 in
                            let wds s = Buffer.add_string buf (U.get_str s) in
-                           schema_value ~wds v;
+                           schema_value ~wds ~wcs:wds v;
                            (Label.from_int n, U.mk (Buffer.contents buf))
                          end
 		      ) attrs in
@@ -177,7 +182,7 @@ let to_buf ~utf8 buffer ns_table v =
     match q with
       | Pair ((Xml _ | XmlNs _) as x, q) -> print_elt [] x; print_content q
       | Atom a when a = Sequence.nil_atom -> ()
-      | v -> schema_value ~wds v
+      | v -> schema_value ~wds ~wcs v
   in
   document_start ();
   print_elt (Ns.Printer.prefixes printer) v

runtime/value.ml

@@ -284,6 +284,11 @@ let rec print ppf v =
 	Format.fprintf ppf "<concat:%a;%a>" print x print y
     | Abstract ("float",o) ->
 	Format.fprintf ppf "%f" (Obj.magic o : float)
+    | Abstract ("cdata",o) ->
+        let s = Utf8.get_str (Obj.magic o : Utf8.t) in
+        Format.fprintf ppf "'%s'" s
+        (* Format.fprintf ppf "%s" (Utf8.get_str (Obj.magic o :
+            * Encodings.Utf8.t)) *)
     | Abstract (s,_) ->
 	Format.fprintf ppf "<abstract=%s>" s
     | Absent -> 	
@@ -417,8 +422,12 @@ let rec compare x y =
 	  raise (CDuceExn (string_latin1 "comparing functional values"))
       | Abstract (s1,v1), Abstract (s2,v2) ->
 	  let c = Types.Abstract.T.compare s1 s2 in if c <> 0 then c 
-	  else Pervasives.compare (Obj.magic v1 : float) (Obj.magic v2 : float)
-	    (* raise (CDuceExn (string_latin1 "comparing abstract values")) *)
+	  else begin
+              match s1 with
+              |"float" -> Pervasives.compare (Obj.magic v1 : float) (Obj.magic v2 : float)
+              |"cdata" -> Pervasives.compare (Obj.magic v1 : Encodings.Utf8.t) (Obj.magic v2 : Encodings.Utf8.t)
+              |_ -> raise (CDuceExn (string_latin1 "comparing abstract values"))
+          end
       | Absent,_ | _,Absent ->
 	  Format.fprintf Format.std_formatter
 	    "ERR: Compare %a %a@." print x print y;
@@ -713,6 +722,9 @@ let print_utf8 v =
 let float n =
   Abstract ("float", Obj.repr n)
 
+let cdata n =
+  Abstract ("cdata", Obj.repr n)
+
 let cduce2ocaml_option f v =
   match normalize v with
     | Pair (x,y) -> Some (f x)

runtime/value.mli

@@ -83,6 +83,7 @@ val flatten : t -> t
 val append : t -> t -> t
 
 val float: float -> t
+val cdata: string -> t
 
 val get_string_latin1 : t -> string
 val get_string_utf8 : t -> U.t * t

types/builtin.ml

@@ -116,6 +116,12 @@ let exn_namespaces = lazy (
       Value.string_latin1 "namespaces"))
 )
 
+let exn_cdata_of = lazy (
+  Value.CDuceExn (
+    Value.Pair (
+      Value.Atom (Atoms.V.mk_ascii "Invalid_argument"),
+      Value.string_latin1 "cdata_of"))
+)
 
 let eval_load_file ~utf8 e =
   Cduce_loc.protect_op "load_file";
@@ -439,3 +445,11 @@ register_fun "float_of" string float
      let (s,_) = Value.get_string_utf8 v in
      try Value.float (float_of_string (U.get_str s))
      with Failure _ -> raise (Lazy.force exn_float_of));;
+
+(* cdata *)
+
+register_fun "cdata_of" string string
+  (fun v ->
+     let (s,_) = Value.get_string_utf8 v in
+     try Value.cdata (U.get_str s)
+     with Failure _ -> raise (Lazy.force exn_cdata_of));;

typing/typer.ml

@@ -131,12 +131,7 @@ let find_id env0 env loc head x =
   with Not_found when head ->
     try ECDuce (!load_comp_unit x)
     with Not_found ->
-      if ((match (U.get_str x).[0] with 'A'..'Z' -> true | _ -> false)
-	   && !has_ocaml_unit x)
-      then EOCaml (U.get_str x)
-      else 
-	error loc ("Cannot resolve this identifier " ^ 
-		      (Ns.QName.to_string id))
+      error loc "Cannot resolve this identifier"
 
 let find_id_comp env0 env loc x =
   if ((match (U.get_str x).[0] with 'A'..'Z' -> true | _ -> false)
@@ -246,16 +241,11 @@ let type_ns env loc p ns =
       ns = Ns.add_prefix p ns env.ns;
       ids = Env.add (Ns.empty,p) (ENamespace ns) env.ids }
       
-let cduce_conv = ref (fun _ -> failwith "cduce conv not initialized")
+
 
 let find_global_type env loc ids =
   match find_global env loc ids with
     | Type t | ESchemaComponent (t,_) -> t
-    | EOCamlComponent s ->
-	let t = !cduce_conv s in
-	let v = ident env loc (U.mk s) in
-	Types.Print.register_global "" v t ;
-	t    
     | _ -> error loc "This path does not refer to a type"
 
 let find_global_schema_component env loc ids =

typing/typer.mli

@@ -69,4 +69,3 @@ val has_static_external: (string -> bool) ref
 
 val load_schema: 
   (string -> string -> Ns.Uri.t * (Types.t * Schema_validator.t) Ident.Env.t) ref
-val cduce_conv : (string -> Types.t) ref

web/contacts.xml

@@ -43,27 +43,57 @@ project.
 Do you want to see <local href="img">what we look like</local> ?
 </p>
 
+<section title="CDuce @ Gallium (INRIA Rocquencourt)">
+
+<p>
+Research group: <a href="http://cristal.inria.fr">Gallium project</a>.
+</p>
+
 <ul>
 <li>
-  <a href="http://alain.frisch.fr/">
+  <a href="http://www.eleves.ens.fr/home/frisch/">
    Alain Frisch
-  </a> (now at <a href="http://www.lexifi.com">LexiFi</a>): <i>project
-  leader, main developer</i>.
+  </a> (Research associate): <i>project leader, main developer</i>.
 </li>
+</ul>
+
+</section>
+
+<section title="CDuce @ ENS (Paris)">
+
+<p>
+Research group: <a
+href="http://www.di.ens.fr/~castagna/EQUIPE/">Language group</a>.
+</p>
+
+<ul>
 <li>
   <a href="http://www.di.ens.fr/~castagna/">
   Giuseppe Castagna
-  </a> (CNRS researcher, PPS laboratory): <i>project leader</i>.
+  </a> (CNRS researcher): <i>project leader</i>.
+</li>
+<li>
+  <a href="http://www.di.ens.fr/~gesbert">
+  Nils Gesbert</a> (Post Doc): <i>concurrency for CDuce</i>.
 </li>
+
+
+</ul>
+</section>
+
+<section title="CDuce @ LRI (Orsay)">
+
+<p>
+Research group: <a
+href="http://www.lri.fr/bd/introduction.en.shtml">Database group</a>.
+</p>
+
+<ul>
 <li>
   <a href="http://www.lri.fr/~benzaken/">
   Vronique Benzaken
   </a> (Prof. Univ. Paris 11): <i>project leader</i>.
 </li>
-<li>
-  <a href="http://www.di.ens.fr/~gesbert">
-  Nils Gesbert</a> (Post Doc): <i>concurrency for CDuce</i>.
-</li>
 <li>
   <a href="http://www.lri.fr/~burelle/">
    Marwan Burelle
@@ -84,24 +114,7 @@ Do you want to see <local href="img">what we look like</local> ?
 </li>
 </ul>
 
-<p>
-Our work on CDuce was supported by the following research
-groups:
-</p>
-<ul>
-<li>
-<a href="http://www.di.ens.fr/~castagna/EQUIPE/">Language group</a>,
-ENS Paris.
-</li>
-<li>
-<a href="http://www.lri.fr/bd/introduction.en.shtml">Database
-  group</a>, Paris-Sud 11 University.
-</li>
-<li><a href="http://gallium.inria.fr">Gallium project</a>, INRIA Rocquencourt.
-</li>
-<li><a href="http://www.pps.jussieu.fr/">PPS laboratory</a>, Paris 7 University.
-</li>
-</ul>
+</section>
 
 <section title="Former interns and students">
 <ul>