Commit 069fd5aa authored by Pietro Abate's avatar Pietro Abate

clean up

parent ae22ade3
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
......
......@@ -4,5 +4,4 @@
*.cma
*.cmxa
cmi2ml
asttypes.ml
ocaml_files
asttypes.ml
\ No newline at end of file
......@@ -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);
......
......@@ -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
......
......@@ -31,4 +31,4 @@ val print_ocaml : Format.formatter -> Types.type_expr -> unit
val find_value: string -> t * int
val find_type : string -> t
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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));;
......@@ -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 =
......
......@@ -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
......@@ -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>
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment