Commit 3102bb87 authored by Julien Lopez's avatar Julien Lopez
Browse files

Merge branch 'stable'

parents fa0ccffb c09f4de2
[submodule "ocaml"]
path = ocaml
url = https://github.com/ocaml/ocaml.git
......@@ -171,3 +171,37 @@ the CDuce command line.
* expat is more efficient than PXP, and produces smaller executables.
* for PXP, ocamllex lexers are more efficient than wlex lexers.
------------------------------------------------------------------------------
Compile Cduce 0.5.5 using ocaml 3.12.1 and opam
------------------------------------------------------------------------------
The lastest stable version compatible with ocaml 3.12.1 is cudce 0.5.5
the git branch ocamlinterface is a fork from tag 0.5.5 and links the
ocaml source code (tags/3.12.1) via a git submodule. To correctly setup
the environment, first you need to switch on the ocamlinterface and
setup the ocaml submodule.
git clone -b ocamlinterface https://git.cduce.org/cduce
git submodule init
git submodule update
Then using OPAM you need to install and configure the correct compiler and
modules needed to build cduce. Ocamlfind will take care of installing the
cduce libraries and make them available.
./opam_config.sh 3.12.1
./configure --mliface=ocaml --prefix=$LOCALSWDIR
make
make install
ocamlfind list | grep cduce
find $HOME/.opam/ -name cduce_lib\*
which cduce
The directory tests contains few tests to check if the ocaml interface was
compiled correctly.
cd tests/ocaml
make
......@@ -95,8 +95,11 @@ cvs_snapshot_bin: clean
scp cduce-cvs-linux-static.tar.gz cduce@di.ens.fr:public_html/download
.PHONY: test
test:
$(MAKE) -C tests test
test: all
@tests/test.sh
extendedtest: all
@tests/test.sh -e
############ CGI DEMO ###################
......
......@@ -11,6 +11,7 @@ ifneq ($(ML_INTERFACE), false)
INSTALL_BINARIES += cduce_mktop
endif
OUNIT_TESTS=eval cdnum cdsdl misc
ifeq ($(NATIVE),true)
all: cduce_lib.cmxa
......@@ -20,7 +21,7 @@ PACKAGES = dynlink camlp4 ulex pcre num netstring
# Call make with VERBOSE=true to get a trace of commands
VERBOSE=false
VERBOSE?=false
ifneq ($(VERBOSE), true)
HIDE=@
......@@ -114,7 +115,7 @@ install_lib:
$(HIDE)(sed "s/%REQ%/$(PACKAGES)/" < META.in | sed "s/%VER%/$(VERSION)/" > META)
$(HIDE)-$(OCAMLFIND) remove cduce
$(HIDE)-$(OCAMLFIND) install cduce META \
cduce_lib.cmi $(wildcard *.cma) $(wildcard *.cmxa) $(wildcard *.a) \
lib/cduce_lib.cmi lib/cduce_lib.cma lib/cduce_lib.cmxa lib/cduce_lib.a \
uninstall:
......@@ -259,9 +260,10 @@ cduce_packed: cduce_packed.$(EXTENSION)
cduce_lib.$(EXTENSION_LIB): $(OBJECTS:.cmo=.$(EXTENSION))
@echo "Pack cduce_lib.$(EXTENSION)"
$(HIDE)$(COMPILE) -o cduce_lib.$(EXTENSION) $(INCLUDES) -pack $^
@test -e lib || mkdir lib
$(HIDE)$(COMPILE) -o lib/cduce_lib.$(EXTENSION) $(INCLUDES) -pack $^
@echo "Build $@"
$(HIDE)$(COMPILE) -a -o $@ cduce_lib.$(EXTENSION)
$(HIDE)$(COMPILE) -a -o lib/$@ lib/cduce_lib.$(EXTENSION)
dtd2cduce: tools/dtd2cduce.ml
@echo "Build $@"
......@@ -287,6 +289,11 @@ clean:
rm -f configure.log
rm -rf web/doc
rm -f META
rm -rf lib
$(RM) tests/schema/regtest/test.cd tests/schema/regtest/test.log
$(RM) tests/schema/test.cd tests/schema/test.log tests/misc/log tests/misc/memento.html tests/xsltmark/log tests/cql/log
$(RM) oUnit-* tests/ocaml/misc/consts.ml tests/ocaml/misc/consts.cdo tests/ocaml/misc/consts.cmi tests/ocaml/misc/consts.cmo tests/ocaml/latypes/latypes2* tests/ocaml/latypes/latypes tests/ocaml/latypes/latypes.c[dm][oxi] tests/ocaml/latypes/latypestest.cm[io]
for i in $(OUNIT_TESTS); do $(RM) `echo tests/ocaml/$$i/$$i tests/ocaml/$$i/$$i.ml tests/ocaml/$$i/$$i.c[dm][oxi] tests/ocaml/$$i/$${i}test.cm[io]`; done
distclean: clean
rm -f Makefile.conf
......
Subproject commit 35b008173b9a6af2ca3de5dacbc44367dbe6defc
......@@ -22,7 +22,7 @@ ocaml_files:
cp location.ml ocaml_files/location.ml
cp ocaml_files/asttypes.mli ocaml_files/asttypes.ml
sed s=STDLIB=$(STDLIB)= config.ml > ocaml_files/config.ml
grep cmi_magic $(OCAML_SRC)/utils/config.mlp >> ocaml_files/config.ml
grep cmi_magic $(OCAML_SRC)/utils/config.mlp | head -1 >> ocaml_files/config.ml
caml_cduce.cmo: ocaml_files
@echo "Build $@"
......@@ -52,19 +52,19 @@ COPY_FILES=\
typing/btype.ml typing/oprint.ml \
typing/subst.ml typing/predef.ml \
typing/datarepr.ml typing/env.ml \
typing/ctype.ml typing/ctype.mli typing/printtyp.ml
typing/ctype.ml typing/ctype.mli typing/printtyp.ml typing/cmi_format.mli typing/cmi_format.ml
COMPILE_FILES=\
asttypes.mli outcometree.mli asttypes.ml \
warnings.ml location.mli asttypes.mli outcometree.mli annot.mli asttypes.ml \
config.ml misc.ml tbl.ml \
clflags.ml consistbl.ml warnings.ml terminfo.ml \
location.mli location.ml annot.mli longident.ml \
clflags.ml consistbl.ml terminfo.ml \
location.ml longident.ml \
ident.ml path.ml \
primitive.ml types.ml \
btype.ml oprint.ml \
subst.ml predef.ml \
datarepr.ml env.ml ctype.mli ctype.ml printtyp.ml
datarepr.ml cmi_format.mli cmi_format.ml env.ml ctype.mli ctype.ml printtyp.ml
COMPILE_FILES_ML=$(filter %.ml,$(COMPILE_FILES))
OBJECTS=$(COMPILE_FILES_ML:.ml=.cmo)
XOBJECTS=$(COMPILE_FILES_ML:.ml=.cmx)
\ No newline at end of file
XOBJECTS=$(COMPILE_FILES_ML:.ml=.cmx)
......@@ -3,6 +3,7 @@
open Lexing
type t = { loc_start: position; loc_end: position; loc_ghost: bool }
type 'a loc = { txt: 'a; loc: t }
let none = { loc_start = dummy_pos; loc_end = dummy_pos; loc_ghost = true }
let dummy x = assert false
......@@ -23,3 +24,9 @@ let prerr_warning = dummy
let echo_eof = dummy
let reset = dummy
let highlight_locations = dummy
let mknoloc = dummy
let mkloc = dummy
let print_loc = dummy
let print_filename = dummy
let show_filename = dummy
let absname = ref true
......@@ -47,6 +47,13 @@ let consId s =
in
aux 0
let ident_to_string list =
let rec _ident_to_string list res = match list with
| (id, x) :: rest -> _ident_to_string rest (res @ [id.Caml_cduce.Ident.name, x])
| [] -> res
in
_ident_to_string list [];;
let rec typ t =
try IntHash.find memo_typ t.uid
with Not_found ->
......@@ -62,9 +69,9 @@ and typ_descr = function
| Tuple tl -> Types.tuple (List.map typ tl)
| PVariant l -> bigcup pvariant l
| Variant (_,l,_) -> bigcup variant l
| Record (_,l,_) ->
let l = List.map (fun (lab,t) -> label lab, typ t) l in
Types.record_fields (false,(LabelMap.from_list_disj l))
| Record (_,l,_) -> let l = ident_to_string l in
let l = List.map (fun (lab,t) -> label lab, typ t) l in
Types.record_fields (false, (LabelMap.from_list_disj l))
| Abstract "int" -> Builtin_defs.caml_int
| Abstract "char" -> Builtin_defs.char_latin1
| Abstract "string" -> Builtin_defs.string_latin1
......@@ -86,8 +93,10 @@ and pvariant = function
| (lab, Some t) -> Types.times (Types.cons (atom lab)) (typ t)
and variant = function
| (lab, []) -> atom lab
| (lab, c) -> Types.tuple (Types.cons (atom lab) :: List.map typ c)
| (lab, [], None) -> atom lab.Caml_cduce.Ident.name
| (lab, [], Some o) -> Types.tuple (Types.cons (atom lab.Caml_cduce.Ident.name) :: List.map typ [o])
| (lab, c, Some o) -> Types.tuple (Types.cons (atom lab.Caml_cduce.Ident.name) :: List.map typ (c@[o]))
| (lab, c, None) -> Types.tuple (Types.cons (atom lab.Caml_cduce.Ident.name) :: List.map typ c)
(* Syntactic tools *)
......@@ -218,70 +227,74 @@ and to_cd_descr e = function
| Link t -> to_cd e t
| Arrow (l,t,s) ->
(* let y = <...> in Value.Abstraction ([t,s], fun x -> s(y ~l:(t(x))) *)
protect e
protect e
(fun y ->
let x = mk_var () in
let arg = to_ml <:expr< $lid:x$ >> t in
let res = to_cd (call_lab y l arg) s in
let abs = <:expr< fun $lid:x$ -> $res$ >> in
let iface =
if !gen_types then
let tt = register_type (Types.descr (typ t)) in
let ss = register_type (Types.descr (typ s)) in
<:expr< Some [($tt$,$ss$)] >>
else <:expr< None >> in
<:expr< Value.Abstraction ($iface$,$abs$) >>
let x = mk_var () in
let arg = to_ml <:expr< $lid:x$ >> t in
let res = to_cd (call_lab y l arg) s in
let abs = <:expr< fun $lid:x$ -> $res$ >> in
let iface =
if !gen_types then
let tt = register_type (Types.descr (typ t)) in
let ss = register_type (Types.descr (typ s)) in
<:expr< Some [($tt$,$ss$)] >>
else <:expr< None >> in
<:expr< Value.Abstraction ($iface$,$abs$) >>
)
| Tuple tl ->
(* let (x1,...,xn) = ... in Value.Pair (t1(x1), Value.Pair(...,tn(xn))) *)
let vars = mk_vars tl in
<:expr< let $pat_tuple vars$ = $e$ in $tuple (tuple_to_cd tl vars)$ >>
let vars = mk_vars tl in
<:expr< let $pat_tuple vars$ = $e$ in $tuple (tuple_to_cd tl vars)$ >>
| PVariant l ->
(* match <...> with
| `A -> Value.atom_ascii "A"
| `B x -> Value.Pair (Value.atom_ascii "B",t(x))
*)
let cases =
List.map
(function
| (lab,None) -> <:match_case< `$lid:lab$ -> $atom_ascii lab$ >>
| (lab,Some t) -> <:match_case< `$lid:lab$ x ->
$pair (atom_ascii lab) (to_cd <:expr< x >> t)$ >>
) l in
pmatch e cases
let cases =
List.map
(function
| (lab,None) -> <:match_case< `$lid:lab$ -> $atom_ascii lab$ >>
| (lab,Some t) -> <:match_case< `$lid:lab$ x ->
$pair (atom_ascii lab) (to_cd <:expr< x >> t)$ >>
) l in
pmatch e cases
| Variant (p,l,_) ->
(* match <...> with
| P.A -> Value.atom_ascii "A"
| P.B (x1,x2,..) -> Value.Pair (Value.atom_ascii "B",...,Value.Pair(tn(x)))
*)
let cases =
List.map
(function
| (lab,[]) ->
let pat = match lab with (* Stupid Camlp4 *)
| "true" -> <:patt< True >>
| "false" -> <:patt< False >>
| lab -> <:patt< $id: id (p^lab)$ >>
in
<:match_case< $pat$ -> $atom_ascii lab$ >>
| (lab,tl) ->
let vars = mk_vars tl in
<:match_case< $id: id (p^lab)$ $pat_tuple vars$ ->
$tuple (atom_ascii lab :: tuple_to_cd tl vars)$ >>
) l in
pmatch e cases
let cases =
List.map
(function
| (lab,[],None) ->
let pat = match lab.Caml_cduce.Ident.name with (* Stupid Camlp4 *)
| "true" -> <:patt< True >>
| "false" -> <:patt< False >>
| lab -> <:patt< $id: id (p^lab)$ >>
in
<:match_case< $pat$ -> $atom_ascii lab.Caml_cduce.Ident.name$ >>
| (lab,tl,Some o) ->
let vars = mk_vars (tl@[o]) in
<:match_case< $id: id (p^(lab.Caml_cduce.Ident.name))$ $pat_tuple vars$ ->
$tuple (atom_ascii lab.Caml_cduce.Ident.name :: tuple_to_cd (tl@[o]) vars)$ >>
| (lab,tl,None) ->
let vars = mk_vars tl in
<:match_case< $id: id (p^(lab.Caml_cduce.Ident.name))$ $pat_tuple vars$ ->
$tuple (atom_ascii lab.Caml_cduce.Ident.name :: tuple_to_cd tl vars)$ >>
) l in
pmatch e cases
| Record (p,l,_) ->
(* let x = <...> in Value.record [ l1,t1(x.P.l1); ...; ln,x.P.ln ] *)
protect e
protect e
(fun x ->
let l =
List.map
(fun (lab,t) ->
let e = to_cd <:expr<$x$.$id:id (p^lab)$>> t in
<:expr< ($label_ascii lab$, $e$) >>)
l
in
<:expr< Value.record $list_lit l$ >>)
let l =
List.map
(fun (lab,t) ->
let lab = lab.Caml_cduce.Ident.name in
let e = to_cd <:expr<$x$.$id:id (p^lab)$>> t in
<:expr< ($label_ascii lab$, $e$) >>) l
in
<:expr< Value.record $list_lit l$ >>)
| Abstract "int" -> <:expr< Value.ocaml2cduce_int $e$ >>
| Abstract "char" -> <:expr< Value.ocaml2cduce_char $e$ >>
......@@ -387,19 +400,41 @@ and to_ml_descr e = function
let cases =
List.map
(function
| (lab,[]) ->
| (lab,[],None) ->
let lab = lab.Caml_cduce.Ident.name in
let pa = <:patt< ($str: String.escaped lab$, None) >>
and e = match lab with (* Stupid Camlp4 *)
| "true" -> <:expr< True >>
| "false" -> <:expr< False >>
| lab -> <:expr< $id:id (p ^ lab)$ >> in
<:match_case< $pa$ -> $e$ >>
| (lab,[t]) ->
| (lab,[t],None) ->
let lab = lab.Caml_cduce.Ident.name in
let x = mk_var () in
let ex = <:expr< $lid:x$ >> in
<:match_case< ($str: String.escaped lab$, Some $lid:x$) ->
$id:id (p ^ lab)$ $to_ml ex t$ >>
| (lab,tl) ->
| (lab,[],Some o) ->
let lab = lab.Caml_cduce.Ident.name in
let x = mk_var () in
let ex = <:expr< $lid:x$ >> in
<:match_case< ($str: String.escaped lab$, Some $lid:x$) ->
$id:id (p ^ lab)$ $to_ml ex o$ >>
| (lab,tl,Some o) ->
let lab = lab.Caml_cduce.Ident.name in
let vars = mk_vars (tl@[o]) in
let x = mk_var () in
<:match_case< ($str: String.escaped lab$, Some $lid:x$) ->
$ matches
<:expr< $lid:x$ >> (
List.fold_left
(fun x (t, id) ->
Ast.ExApp(_loc, x, <:expr<$to_ml <:expr< $lid:id$ >> t$>>))
<:expr< $id:consId (p ^ lab)$ >>
(List.combine (tl@[o]) vars))
vars $ >>
| (lab,tl,None) ->
let lab = lab.Caml_cduce.Ident.name in
let vars = mk_vars tl in
let x = mk_var () in
<:match_case< ($str: String.escaped lab$, Some $lid:x$) ->
......@@ -424,6 +459,7 @@ and to_ml_descr e = function
let l =
List.map
(fun (lab,t) ->
let lab = lab.Caml_cduce.Ident.name in
let e =
to_ml <:expr< Value.get_field $x$ $label_ascii lab$ >> t in
<:rec_binding< $id: id (p^lab)$ = $e$ >>) l in
......
......@@ -16,15 +16,15 @@ and def =
| Arrow of string * t * t
| Tuple of t list
| PVariant of (string * t option) list (* Polymorphic variant *)
| Variant of string * (string * t list) list * bool
| Record of string * (string * t) list * bool
| Variant of string * (Ident.t * t list * t option) list * bool
| Record of string * (Ident.t * t) list * bool
| Builtin of string * t list
| Abstract of string
| Var of int
module IntMap =
module IntMap =
Map.Make(struct type t = int let compare : t -> t -> int = compare end)
module IntSet =
module IntSet =
Set.Make(struct type t = int let compare : t -> t -> int = compare end)
module StringSet = Set.Make(struct type t = string let compare : t -> t -> int = compare end)
......@@ -46,7 +46,7 @@ let rec print_slot ppf slot =
Format.fprintf ppf "X%i:=%a" slot.uid print_def slot.def
)
)
else
else
print_def ppf slot.def
and print_def ppf = function
......@@ -64,15 +64,15 @@ and print_def ppf = function
and print_palt ppf = function
| lab, None -> Format.fprintf ppf "`%s" lab
| lab, Some t -> Format.fprintf ppf "`%s of %a" lab print_slot t
and print_alt ppf = function
| (lab,[]) ->
Format.fprintf ppf "%s" lab
| (lab,l) ->
Format.fprintf ppf "%s of [%a]" lab (print_sep print_slot ",") l
| (lab,[],_) ->
Format.fprintf ppf "%s" lab.Ident.name
| (lab,l,_) ->
Format.fprintf ppf "%s of [%a]" lab.Ident.name (print_sep print_slot ",") l
and print_field ppf (lab,t) =
Format.fprintf ppf "%s:%a" lab print_slot t
Format.fprintf ppf "%s:%a" lab.Ident.name print_slot t
let print = print_slot
......@@ -94,7 +94,9 @@ let reg_uid t =
| Arrow (_,t1,t2) -> aux t1; aux t2
| Tuple tl -> List.iter aux tl
| PVariant pl -> List.iter (function (_,Some t) -> aux t | _ -> ()) pl
| Variant (_,pl,_) -> List.iter (fun (_,tl) -> List.iter aux tl) pl
| Variant (_,pl,_) -> List.iter (function
(_,tl,Some o) -> List.iter aux (tl@[o])
| (_,tl,None) -> List.iter aux tl) pl
| Record (_,tl,_) -> List.iter (fun (_,t) -> aux t) tl
| Builtin (_,tl) -> List.iter aux tl
| _ -> ()
......@@ -106,32 +108,33 @@ let reg_uid t =
let builtins =
List.fold_left (fun m x -> StringSet.add x m) StringSet.empty
[
"list"; "Pervasives.ref";
"list"; "Pervasives.ref";
"unit"; "array";
"Big_int.big_int";
"option";
"Cduce_lib.Value.t";
"Cduce_lib.Value.t";
"Cduce_lib.Encodings.Utf8.t";
"Cduce_lib.Atoms.V.t";
]
let vars = ref []
let get_var id =
let get_var id =
try List.assq id !vars
with Not_found ->
with Not_found ->
let i = List.length !vars in
vars := (id,i) :: !vars;
vars := (id,i) :: !vars;
i
let constr_table = Hashtbl.create 1024
type env = { constrs: StringSet.t; seen: IntSet.t; vars: t IntMap.t }
(* Take the file p, if it is from the builtins, open it; else *)
let rec unfold_constr env p args =
let args = List.map (unfold env) args in
let pn = Path.name p in
if StringSet.mem pn builtins
if StringSet.mem pn builtins
then ( let slot = new_slot () in slot.def <- Builtin (pn,args); slot )
else
let args_id = List.map (fun t -> t.uid) args in
......@@ -144,16 +147,16 @@ let rec unfold_constr env p args =
slot.recurs <- 1;
Hashtbl.add constr_table k slot;
let decl =
let decl =
try Env.find_type p !ocaml_env
with Not_found -> failwith ("Cannot resolve path " ^ pn) in
let env =
{ env with
let env =
{ env with
constrs = StringSet.add pn env.constrs;
vars =
List.fold_left2
(fun vars a t -> IntMap.add a.id t vars)
vars =
List.fold_left2
(fun vars a t -> IntMap.add a.id t vars)
env.vars decl.type_params args } in
let prefix = match p with
......@@ -161,13 +164,16 @@ let rec unfold_constr env p args =
| Path.Pdot (p,_,_) -> Path.name p ^ "."
| _ -> assert false in
slot.def <-
slot.def <-
(match decl.type_kind, decl.type_manifest with
| Type_variant (cstrs), _ ->
let cstrs =
List.map
(fun (cst,f) -> (cst,List.map (unfold env) f)) cstrs in
Variant (prefix, cstrs, true)
(* TODO: Check this solution *)
List.map (function (cst,f,Some o)
-> (cst,List.map (unfold env) f,Some (unfold env o))
| (cst,f,None) -> (cst,List.map (unfold env) f,None)) cstrs in
(*OLD: (fun (cst,f) -> (cst,List.map (unfold env) f)) cstrs in *)
Variant (prefix, cstrs, true)
| Type_record (f,_), _ ->
let f = List.map (fun (l,_,t) -> (l,unfold env t)) f in
Record (prefix, f, true)
......@@ -178,34 +184,34 @@ let rec unfold_constr env p args =
| [] -> Abstract pn
| l ->raise (PolyAbstract pn)));
slot
and unfold env ty =
if IntSet.mem ty.id env.seen then failwith "Unguarded recursion";
let env = { env with seen = IntSet.add ty.id env.seen } in
let env = { env with seen = IntSet.add ty.id env.seen } in
let slot = new_slot () in
slot.def <-
(match ty.desc with
| Tarrow (l,t1,t2,_) ->
| Tarrow (l,t1,t2,_) ->
let t1 = unfold env t1 in
let t2 = unfold env t2 in
let t2 = unfold env t2 in
Arrow (l, t1,t2)
| Ttuple tyl -> Tuple (List.map (unfold env) tyl)
| Tvariant rd ->
let fields =
let fields =
List.fold_left
(fun accu (lab,f) ->
(fun accu (lab,f) ->
match f with
| Rpresent (Some t)
| Reither(true, [t], _, _) ->
| Rpresent (Some t)
| Reither(true, [t], _, _) ->
(lab, Some (unfold env t)) :: accu
| Rpresent None
| Rpresent None
| Reither(true, [], _, _) -> (lab, None) :: accu
| Rabsent -> Printf.eprintf "Warning: Rabsent not supported"; accu
| Reither _ -> Printf.eprintf "Warning: Reither not supported"; accu
) []
rd.row_fields in
PVariant fields
| Tvar ->
| Tvar s ->
(try Link (IntMap.find ty.id env.vars)
with Not_found -> Var (get_var ty.id))
| Tconstr (p,args,_) ->
......@@ -214,7 +220,7 @@ and unfold env ty =
);
slot
let unfold ty =
let unfold ty =
vars := [];
Hashtbl.clear constr_table; (* Get rid of that (careful with exceptions) *)
let t = unfold { seen = IntSet.empty; constrs = StringSet.empty;
......@@ -243,7 +249,7 @@ let find_value v =
let values_of_sig name sg =
List.fold_left
(fun accu v -> match v with
| Tsig_value (id,_) ->
| Sig_value (id,_) ->
let id = Ident.name id in
(match id.[0] with
| 'a'..'z' | '_' ->
......@@ -255,14 +261,14 @@ let values_of_sig name sg =
) [] sg
let load_module name =
let load_module name =
Config.load_path := Config.standard_library :: !Loc.obj_path;
let li = Longident.parse name in
ocaml_env := Env.initial;
let (_,mty) = Env.lookup_module li Env.initial in
match mty with
| Tmty_signature sg -> values_of_sig name sg
| _ -> raise (Loc.Generic
| Mty_signature sg -> values_of_sig name sg
| _ -> raise (Loc.Generic
(Printf.sprintf "Module %s is not a structure" name))
(*
......@@ -290,19 +296,19 @@ let read_cmi name =
let values = ref [] in