Copyright (C) 2006 Grégoire Henry distributed under the terms of the LGPL (for librairies Ty and SafeUnmarshalling) and the QPL (for the compiler patch) with the same exceptions as the ones used by the Objective Caml distribution by INRIA. diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/bytecomp/translcore.ml ocaml/bytecomp/translcore.ml --- ocaml.cvs/bytecomp/translcore.ml 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/bytecomp/translcore.ml 2006-03-28 23:25:53.000000000 +0200 @@ -734,6 +734,7 @@ cl_loc = e.exp_loc; cl_type = Tcty_signature cty; cl_env = e.exp_env } + | Texp_tyrepr ty -> Transltyrepr.transl_expr e.exp_env e.exp_loc ty and transl_list expr_list = List.map transl_exp expr_list diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/bytecomp/translmod.ml ocaml/bytecomp/translmod.ml --- ocaml.cvs/bytecomp/translmod.ml 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/bytecomp/translmod.ml 2006-03-28 23:25:53.000000000 +0200 @@ -294,7 +294,9 @@ end; transl_structure fields cc rootpath rem | Tstr_type(decls) :: rem -> - transl_structure fields cc rootpath rem + let ext_fields = List.rev_append (tyrepr_bound_idents decls) fields in + Transltyrepr.transl_type_decl decls + (transl_structure ext_fields cc rootpath rem) | Tstr_exception(id, decl) :: rem -> Llet(Strict, id, transl_exception id (field_path rootpath id) decl, transl_structure (id :: fields) cc rootpath rem) @@ -379,7 +381,10 @@ end; transl_store subst rem | Tstr_type(decls) :: rem -> - transl_store subst rem + let ids = tyrepr_bound_idents decls in + let lam = Transltyrepr.transl_type_decl decls (store_idents ids) in + Lsequence(subst_lambda subst lam, + transl_store (add_idents false ids subst) rem) | Tstr_exception(id, decl) :: rem -> let lam = transl_exception id (field_path (global_path glob) id) decl in Lsequence(Llet(Strict, id, lam, store_ident id), @@ -477,7 +482,7 @@ | Tstr_value(rec_flag, pat_expr_list) :: rem -> let_bound_idents pat_expr_list @ defined_idents rem | Tstr_primitive(id, descr) :: rem -> defined_idents rem - | Tstr_type decls :: rem -> defined_idents rem + | Tstr_type decls :: rem -> tyrepr_bound_idents decls @ defined_idents rem | Tstr_exception(id, decl) :: rem -> id :: defined_idents rem | Tstr_exn_rebind(id, path) :: rem -> id :: defined_idents rem | Tstr_module(id, modl) :: rem -> id :: defined_idents rem @@ -579,7 +584,10 @@ | Tstr_primitive(id, descr) -> lambda_unit | Tstr_type(decls) -> - lambda_unit + let idents = tyrepr_bound_idents decls in + Transltyrepr.transl_type_decl + decls + (make_sequence toploop_setvalue_id idents) | Tstr_exception(id, decl) -> toploop_setvalue id (transl_exception id None decl) | Tstr_exn_rebind(id, path) -> diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/bytecomp/transltyrepr.ml ocaml/bytecomp/transltyrepr.ml --- ocaml.cvs/bytecomp/transltyrepr.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml/bytecomp/transltyrepr.ml 2006-05-23 19:47:35.000000000 +0200 @@ -0,0 +1,350 @@ +open Types +open Btype +open Ctype +open Asttypes +open Lambda +open Misc + +type error = + | Unimplemented + +exception Error of Location.t * error + +let current_loc = ref Location.none + +(** Intermediate tree *) + +type decl = { body: expr; arity: int; } +and expr = { mutable expr : desc; } +and desc = + | Rabstract + | Rconstr of Path.t * expr list + | Rtuple of expr list + | Rarrow of string * expr * expr + | Rvariant of bool * (string * int * expr option) list + + | Rarg of int + | Rsum of string list * (string * expr list) list + | Rrecorddouble of (string * Asttypes.mutable_flag) list + | Rrecord of (string * Asttypes.mutable_flag * expr) list + + | Rvar of int + | Rpoly of int * expr + +(** Convert to the intermediate tree *) + +let shift_var env i = + List.fold_right + (fun (px,ty as e) env -> + match ty.expr with + | Rvar j -> (px, {expr = Rvar (i+j)}) :: env + | _ -> e :: env ) + env + [] + +let todo () = Rabstract (* raise (Error (!current_loc, Unimplemented)) *) +let rec tree_of_typexp env ty = + let ty = repr ty in + let px = proxy ty in + if List.mem_assq px env then List.assq px env else + let tree = { expr = Rabstract; (* dummy value *) } in + let env = (px,tree) :: env in + tree.expr <- tree_of_typexp_1 env ty; + tree + +and tree_of_typexp_1 env ty = + match ty.desc with + | Tvar -> Rabstract + | Ttuple tyl -> Rtuple (List.map (tree_of_typexp env) tyl) + | Tconstr (path, tyl, _) -> Rconstr (path, List.map (tree_of_typexp env) tyl) + | Tvariant row -> + let row = row_repr row in + (* if not row.row_closed then assert false; *) + Rvariant (row.row_closed, + (List.map (tree_of_row_field env) row.row_fields)) + | Tobject _ -> todo () + | Tsubst ty -> tree_of_typexp_1 env ty + | Tpoly (ty, tyl) -> + let i = List.length tyl in + if i = 0 then tree_of_typexp_1 env ty else + let cpt = ref ~-1 in + let env = + List.fold_left + (fun env ty -> incr cpt; (proxy ty, { expr = Rvar !cpt }) :: env) + (shift_var env i) + tyl + in + Rpoly (i,tree_of_typexp env ty) + | Tunivar -> todo () + | Tarrow (l, ty1, ty2, _) -> + let ty1 = + if is_optional l then + match (repr ty1).desc with + | Tconstr (path, [ty], _) when Path.same path Predef.path_option -> + tree_of_typexp env ty + | _ -> raise (Error (!current_loc, Unimplemented)) + (* qu'est ce que (Otyp_stuff "") ? *) + else tree_of_typexp env ty1 in + Rarrow (l, ty1, tree_of_typexp env ty2) + | Tlink _ | Tnil | Tfield _ -> fatal_error "Transltyrepr.tree_of_typexp" + +and tree_of_row_field env (l, f) = + match row_field_repr f with + | Rpresent None -> (l,Btype.hash_variant l,None) + | Rpresent (Some ty) -> (l,Btype.hash_variant l,Some (tree_of_typexp env ty)) + | _ -> assert false + +(** Translate to lambda (see type of generated values in stdlib/ty.ml) *) + +let loops = ref [] + +let rec mark_loops_rec visited ty = + if List.memq ty visited then + if not (List.mem_assq ty !loops) then + loops := (ty, Ident.create "tyrepr") :: !loops else () + else begin + let visited = ty :: visited in + match ty.expr with + | Rtuple tyl + | Rconstr (_, tyl) -> List.iter (mark_loops_rec visited) tyl + | Rarrow (lab, ty1, ty2) -> + mark_loops_rec visited ty1; + mark_loops_rec visited ty2 + | _ -> () + end + +let reset_and_mark_loops ty = + loops := []; + mark_loops_rec [] ty + +let posf f l = + let rec aux i l = + match l with + | [] -> raise Not_found + | e::l -> if f e then i else aux (succ i) l + in aux 0 l + +let rec transl_tree_rec tree = + try Lvar (List.assq tree !loops) + with Not_found -> transl_tree_rec_1 tree +and transl_tree_rec_1 tree = + Lprim(Pmakeblock (0, Mutable),[transl_tree_rec_desc tree; + Lconst(Const_base(Const_int 0)); + Lconst(Const_base(Const_int 0))]) +and transl_decl_tree_rec desc repr = + Lprim(Pmakeblock (0, Mutable),[transl_tree_rec_desc desc; + Lprim(Pmakeblock(0, Immutable),[transl_tree_rec_desc repr]); + Lconst(Const_base(Const_int 0))]) +and transl_tree_rec_desc tree = + match tree.expr with + | Rabstract -> Lconst (Const_base (Const_int 10)) + (* Peut-on parfois faire le lien avec les /custom blocks/ ? *) + | Rconstr (path, []) -> + begin try let tag = posf (Path.same path) [ Predef.path_unit; + Predef.path_bool; + Predef.path_int; + Predef.path_nativeint; + Predef.path_int32; + Predef.path_int64; + Predef.path_char; + Predef.path_string; + Predef.path_float; + Predef.path_exn ] in + Lconst (Const_base (Const_int tag)) + with Not_found -> Lprim(Pmakeblock (6, Immutable), + [transl_path (Path.rename_tyrepr path); + Lprim(Pmakeblock (0, Immutable),[]) ] ) + end + | Rconstr (path, tyl) -> + begin try let tag = posf (Path.same path) [ Predef.path_array; + Predef.path_list; + Predef.path_option; + Predef.path_lazy_t; + Predef.path_tyrepr; + Predef.path_format4; ] in + Lprim(Pmakeblock (tag, Immutable),List.map transl_tree_rec tyl) + with Not_found -> + Lprim(Pmakeblock (6, Immutable), + [transl_path (Path.rename_tyrepr path); + Lprim(Pmakeblock (0, Immutable), + List.map transl_tree_rec tyl ) ] ) + end + | Rtuple tyl -> + Lprim(Pmakeblock (7, Immutable), + [Lprim(Pmakeblock (0, Immutable), + List.map transl_tree_rec tyl )] ) + | Rarrow (lab, ty1, ty2) -> + Lprim(Pmakeblock (8, Immutable), + [Lconst(Const_immstring lab); transl_tree_rec ty1; + transl_tree_rec ty2 ] ) + | Rvariant (closed,row) -> + Lprim(Pmakeblock (9, Immutable), + [if closed + then Lconst (Const_base (Const_int 1)) + else Lconst (Const_base (Const_int 0)); + Lprim(Pmakeblock (0, Immutable), + List.map (fun (lab,tag,ty) -> + Lprim(Pmakeblock (0, Immutable), + [ Lconst(Const_immstring lab); + Lconst (Const_base (Const_int tag)); + match ty with + | None -> + Lconst (Const_base (Const_int 0)) + | Some ty -> + Lprim(Pmakeblock (0, Immutable), + [transl_tree_rec ty] ) ] ) ) + row )] ) + + | Rsum (consts, nconsts) -> + Lprim(Pmakeblock (10, Immutable), + [Lprim(Pmakeblock (0, Immutable), + List.map (fun s -> Lconst(Const_immstring s)) consts); + Lprim(Pmakeblock (0, Immutable), + List.map + (fun (name,args) -> + Lprim(Pmakeblock (0, Immutable), + [ Lconst(Const_immstring name); + Lprim(Pmakeblock (0, Immutable), + List.map transl_tree_rec args) + ] ) ) + nconsts ) ] ) + | Rrecorddouble args -> + Lprim(Pmakeblock (11, Immutable), + [Lprim(Pmakeblock (0, Immutable), + List.map + (fun (name, mut) -> + Lprim(Pmakeblock (0, Immutable), + [Lconst(Const_immstring name); + Lconst(Const_base (Const_int (if mut = Mutable then 1 else 0))) ] ) ) + args ) ]) + | Rrecord args -> + Lprim(Pmakeblock (12, Immutable), + [Lprim(Pmakeblock (0, Immutable), + List.map + (fun (name, mut, tree) -> + Lprim(Pmakeblock (0, Immutable), + [Lconst(Const_immstring name); + Lconst(Const_base (Const_int (if mut = Mutable then 1 else 0))); + transl_tree_rec tree + ] ) ) + args ) ]) + | Rarg i -> Lprim(Pmakeblock (13, Immutable), + [Lconst(Const_base (Const_int i))]) + + | Rpoly (i, ty) -> + Lprim( Pmakeblock (14, Immutable), + [ Lconst(Const_base (Const_int i)); + transl_tree_rec ty ] ) + | Rvar i -> Lprim(Pmakeblock (15, Immutable), + [Lconst(Const_base (Const_int i))]) + +let transl_tree tree = + reset_and_mark_loops tree; + if !loops <> [] then + Lletrec(List.map (fun (tree, id) -> (id, transl_tree_rec_1 tree)) !loops, + transl_tree_rec tree) + else + transl_tree_rec tree + +let make_name path n = + { expr = Rconstr(path,Array.to_list (Array.init n (fun i -> { expr = Rarg i }))) } + +let transl_decl_tree path decl = + reset_and_mark_loops decl.body; + if !loops <> [] then + Lletrec(List.map (fun (tree, id) -> (id, transl_tree_rec_1 tree)) !loops, + transl_decl_tree_rec (make_name path decl.arity) decl.body) + else + transl_decl_tree_rec (make_name path decl.arity) decl.body + + +let transl_expr env loc ty = + current_loc := loc; + normalize_type Env.empty ty; + transl_tree (tree_of_typexp [] ty) + +let tree_of_decl decl = + let cpt = ref ~-1 in + let env = List.map + (fun ty -> incr cpt; (proxy ty, { expr = Rarg !cpt })) + decl.type_params in + let body = + match decl.type_kind with + | Type_abstract -> + begin + match decl.type_manifest with + | None -> { expr = Rabstract } + | Some ty -> tree_of_typexp env ty + end + | Type_variant (arg, _) -> + (* (string * type_expr list) list * private_flag *) + let consts, nconsts = + List.fold_right + (fun (name, tys) (consts, nconsts) -> + if tys = [] then + ((name::consts), nconsts) + else + let arg = List.map + (fun ty -> tree_of_typexp env ty) + tys + in + (consts, ((name,arg)::nconsts)) ) + arg ([],[]) in + { expr = Rsum (consts,nconsts) } + | Type_record (fields, repr, _ ) -> + (* (string * mutable_flag * type_expr) list + * record_representation * private_flag *) + begin + match repr with + | Record_float -> + { expr = Rrecorddouble + (List.map (fun (name,mut,_) -> (name,mut)) fields) } + | Record_regular -> + let fields = List.map + (fun (name,mut,ty) -> + (name,mut,tree_of_typexp env ty)) + fields + in + { expr = Rrecord fields } + end + in + { body = body; arity = decl.type_arity; } + +let transl_decl id decl = + let file, line, char = + Location.get_pos_info decl.type_loc.Location.loc_start in + let pos = Lprim(Pmakeblock (0, Immutable), + [ Lconst(Const_immstring file); + Lconst(Const_base(Const_int line)); + Lconst(Const_base(Const_int char)) ]) in + if !Clflags.keep_type_decl then begin + current_loc := decl.type_loc; + let tree = tree_of_decl decl in + Lprim(Pmakeblock (0, Mutable), + [transl_decl_tree (Path.Pident id) tree; + Lconst(Const_base(Const_int tree.arity)); + Lconst(Const_immstring (Ident.name id)); + pos ] ) + end else + Lprim(Pmakeblock (0, Mutable), + [ transl_tree { expr = Rabstract }; + Lconst(Const_base(Const_int decl.type_arity)); + Lconst(Const_immstring ""); + Lprim(Pmakeblock (0, Immutable), + [ Lconst(Const_immstring ""); + Lconst(Const_base(Const_int 0)); + Lconst(Const_base(Const_int 0)) ]) ] ) + +let transl_type_decl decls body = + Lletrec(List.map + (fun (id,decl) -> (Ident.rename_tyrepr id, + transl_decl id decl )) + decls, + body) + +open Format + +let report_error ppf = function + | Unimplemented -> + fprintf ppf + "Unimplemented" diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/bytecomp/transltyrepr.mli ocaml/bytecomp/transltyrepr.mli --- ocaml.cvs/bytecomp/transltyrepr.mli 1970-01-01 01:00:00.000000000 +0100 +++ ocaml/bytecomp/transltyrepr.mli 2006-03-28 23:25:53.000000000 +0200 @@ -0,0 +1,15 @@ +open Types +open Lambda + +val transl_expr: Env.t -> Location.t -> type_expr -> lambda +val transl_type_decl: + (Ident.t * type_declaration) list -> lambda -> lambda + +type error = + | Unimplemented + +exception Error of Location.t * error + +open Format + +val report_error: formatter -> error -> unit diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/camlp4/compile/compile.sh ocaml/camlp4/compile/compile.sh --- ocaml.cvs/camlp4/compile/compile.sh 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/camlp4/compile/compile.sh 2006-03-28 23:25:53.000000000 +0200 @@ -18,9 +18,9 @@ cat $FILES | sed -e 's/Pcaml.parse_i.*$//' > tmp.ml echo "Compile.entries.val := [$ENTRIES];" >> tmp.ml > tmp.mli -$OTOP/boot/ocamlrun$EXE $OTOP/boot/ocamlc -I $OTOP/boot -c tmp.mli +$OTOP/boot/ocamlrun$EXE $OTOP/boot/ocamlc -noty -I $OTOP/boot -c tmp.mli $OTOP/boot/ocamlrun$EXE ../meta/camlp4r$EXE -I ../meta pa_extend.cmo q_MLast.cmo -meta_action tmp.ml -o tmp.ppo -$OTOP/boot/ocamlrun$EXE $OTOP/boot/ocamlc -I $OTOP/boot -I ../lib -I ../camlp4 -c -impl tmp.ppo +$OTOP/boot/ocamlrun$EXE $OTOP/boot/ocamlc -noty -I $OTOP/boot -I ../lib -I ../camlp4 -c -impl tmp.ppo rm tmp.ppo > tmp.null $OTOP/boot/ocamlrun$EXE ../camlp4/camlp4$EXE ./compile.cmo ./tmp.cmo ../etc/pr_r.cmo ../etc/pr_rp.cmo $ARGS -sep "\n\n" -impl tmp.null && rm tmp.* diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/camlp4/Makefile ocaml/camlp4/Makefile --- ocaml.cvs/camlp4/Makefile 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/camlp4/Makefile 2006-04-03 10:08:06.000000000 +0200 @@ -21,6 +21,7 @@ $(MAKE) clean_cold library_cold compile_cold $(MAKE) promote_cold $(MAKE) clean_cold clean_hot library + $(MAKE) core bootstrap_core clean_hot: for i in $(DIRS) compile; do (cd $$i; $(MAKE) clean); done @@ -49,8 +50,9 @@ bootstrap: backup promote clean_hot all compare backup: + rm -rf boot.new mkdir boot.new - make mv_cvs FROM=boot TO=boot.new + ${MAKE} mv_cvs FROM=boot TO=boot.new mv boot boot.new/SAVED mv boot.new boot diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/camlp4/ocaml_src/tools/ocamlc.sh ocaml/camlp4/ocaml_src/tools/ocamlc.sh --- ocaml.cvs/camlp4/ocaml_src/tools/ocamlc.sh 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/camlp4/ocaml_src/tools/ocamlc.sh 2006-03-28 23:25:53.000000000 +0200 @@ -1,8 +1,8 @@ #!/bin/sh -e if test "`basename $OTOP`" != "ocaml_stuff"; then - COMM=$OTOP/ocamlcomp.sh + COMM="$OTOP/ocamlcomp.sh -noty" else - COMM=ocamlc$OPT + COMM="ocamlc$OPT -noty" fi echo $COMM $* $COMM $* diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/camlp4/ocaml_src/tools/ocamlopt.sh ocaml/camlp4/ocaml_src/tools/ocamlopt.sh --- ocaml.cvs/camlp4/ocaml_src/tools/ocamlopt.sh 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/camlp4/ocaml_src/tools/ocamlopt.sh 2006-03-28 23:25:53.000000000 +0200 @@ -1,8 +1,8 @@ #!/bin/sh -e if test "`basename $OTOP`" != "ocaml_stuff"; then - COMM=$OTOP/ocamlcompopt.sh + COMM="$OTOP/ocamlcompopt.sh -noty" else - COMM=ocamlopt$OPT + COMM="ocamlopt$OPT -noty" fi echo $COMM $* $COMM $* diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/camlp4/tools/ocamlc.sh ocaml/camlp4/tools/ocamlc.sh --- ocaml.cvs/camlp4/tools/ocamlc.sh 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/camlp4/tools/ocamlc.sh 2006-03-28 23:25:53.000000000 +0200 @@ -1,8 +1,8 @@ #!/bin/sh -e if test "`basename $OTOP`" != "ocaml_stuff"; then - COMM=$OTOP/ocamlcomp.sh + COMM="$OTOP/ocamlcomp.sh -noty" else - COMM=ocamlc$OPT + COMM="ocamlc$OPT -noty" fi echo $COMM $* $COMM $* diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/camlp4/tools/ocamlopt.sh ocaml/camlp4/tools/ocamlopt.sh --- ocaml.cvs/camlp4/tools/ocamlopt.sh 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/camlp4/tools/ocamlopt.sh 2006-03-28 23:25:53.000000000 +0200 @@ -1,8 +1,8 @@ #!/bin/sh -e if test "`basename $OTOP`" != "ocaml_stuff"; then - COMM=$OTOP/ocamlcompopt.sh + COMM="$OTOP/ocamlcompopt.sh -noty" else - COMM=ocamlopt$OPT + COMM="ocamlopt$OPT -noty" fi echo $COMM $* $COMM $* diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/configure ocaml/configure --- ocaml.cvs/configure 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/configure 2006-04-03 09:53:53.000000000 +0200 @@ -763,7 +763,7 @@ # Configuration for the libraries -otherlibraries="unix str num dynlink bigarray" +otherlibraries="unix str num dynlink bigarray safe_unmarshaling" # For the Unix library diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/debugger/Makefile ocaml/debugger/Makefile --- ocaml.cvs/debugger/Makefile 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/debugger/Makefile 2006-03-28 23:25:53.000000000 +0200 @@ -31,6 +31,8 @@ ../otherlibs/unix/unix.cma \ ../utils/misc.cmo ../utils/config.cmo \ ../utils/tbl.cmo ../utils/clflags.cmo ../utils/consistbl.cmo \ + ../utils/terminfo.cmo ../utils/warnings.cmo \ + ../parsing/linenum.cmo ../parsing/location.cmo \ ../parsing/longident.cmo \ ../typing/ident.cmo ../typing/path.cmo ../typing/types.cmo \ ../typing/btype.cmo ../typing/primitive.cmo ../typing/typedtree.cmo \ diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/.depend ocaml/.depend --- ocaml.cvs/.depend 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/.depend 2006-10-09 18:21:19.000000000 +0200 @@ -90,8 +90,8 @@ typing/typemod.cmi: typing/types.cmi typing/typedtree.cmi \ parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ typing/includemod.cmi typing/ident.cmi typing/env.cmi -typing/types.cmi: typing/primitive.cmi typing/path.cmi typing/ident.cmi \ - parsing/asttypes.cmi +typing/types.cmi: typing/primitive.cmi typing/path.cmi parsing/location.cmi \ + typing/ident.cmi parsing/asttypes.cmi typing/typetexp.cmi: typing/types.cmi typing/path.cmi parsing/parsetree.cmi \ parsing/longident.cmi parsing/location.cmi typing/env.cmi typing/unused_var.cmi: parsing/parsetree.cmi @@ -157,10 +157,10 @@ typing/btype.cmx parsing/asttypes.cmi typing/parmatch.cmi typing/path.cmo: typing/ident.cmi typing/path.cmi typing/path.cmx: typing/ident.cmx typing/path.cmi -typing/predef.cmo: typing/types.cmi typing/path.cmi typing/ident.cmi \ - typing/btype.cmi parsing/asttypes.cmi typing/predef.cmi -typing/predef.cmx: typing/types.cmx typing/path.cmx typing/ident.cmx \ - typing/btype.cmx parsing/asttypes.cmi typing/predef.cmi +typing/predef.cmo: typing/types.cmi typing/path.cmi parsing/location.cmi \ + typing/ident.cmi typing/btype.cmi parsing/asttypes.cmi typing/predef.cmi +typing/predef.cmx: typing/types.cmx typing/path.cmx parsing/location.cmx \ + typing/ident.cmx typing/btype.cmx parsing/asttypes.cmi typing/predef.cmi typing/primitive.cmo: utils/misc.cmi typing/primitive.cmi typing/primitive.cmx: utils/misc.cmx typing/primitive.cmi typing/printtyp.cmo: typing/types.cmi typing/primitive.cmi typing/predef.cmi \ @@ -235,18 +235,22 @@ parsing/parsetree.cmi typing/mtype.cmi utils/misc.cmi \ parsing/longident.cmi parsing/location.cmi typing/includemod.cmi \ typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/config.cmi \ - utils/clflags.cmi typing/btype.cmi typing/typemod.cmi + utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ + typing/typemod.cmi typing/typemod.cmx: typing/types.cmx typing/typedtree.cmx typing/typedecl.cmx \ typing/typecore.cmx typing/typeclass.cmx typing/subst.cmx \ typing/stypes.cmx typing/printtyp.cmx typing/path.cmx \ parsing/parsetree.cmi typing/mtype.cmx utils/misc.cmx \ parsing/longident.cmx parsing/location.cmx typing/includemod.cmx \ typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/config.cmx \ - utils/clflags.cmx typing/btype.cmx typing/typemod.cmi + utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ + typing/typemod.cmi typing/types.cmo: typing/primitive.cmi typing/path.cmi utils/misc.cmi \ - typing/ident.cmi parsing/asttypes.cmi typing/types.cmi + parsing/location.cmi typing/ident.cmi parsing/asttypes.cmi \ + typing/types.cmi typing/types.cmx: typing/primitive.cmx typing/path.cmx utils/misc.cmx \ - typing/ident.cmx parsing/asttypes.cmi typing/types.cmi + parsing/location.cmx typing/ident.cmx parsing/asttypes.cmi \ + typing/types.cmi typing/typetexp.cmo: utils/warnings.cmi typing/types.cmi utils/tbl.cmi \ typing/printtyp.cmi typing/path.cmi parsing/parsetree.cmi utils/misc.cmi \ parsing/longident.cmi parsing/location.cmi typing/env.cmi \ @@ -284,6 +288,8 @@ bytecomp/translmod.cmi: typing/typedtree.cmi parsing/location.cmi \ bytecomp/lambda.cmi typing/ident.cmi bytecomp/translobj.cmi: bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi +bytecomp/transltyrepr.cmi: typing/types.cmi parsing/location.cmi \ + bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi bytecomp/typeopt.cmi: typing/typedtree.cmi typing/path.cmi \ bytecomp/lambda.cmi bytecomp/bytegen.cmo: typing/types.cmi bytecomp/switch.cmi \ @@ -395,29 +401,31 @@ typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/clflags.cmx \ typing/btype.cmx parsing/asttypes.cmi bytecomp/translclass.cmi bytecomp/translcore.cmo: typing/types.cmi bytecomp/typeopt.cmi \ - typing/typedtree.cmi bytecomp/translobj.cmi typing/primitive.cmi \ - typing/predef.cmi typing/path.cmi utils/misc.cmi bytecomp/matching.cmi \ - parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \ - utils/config.cmi utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ - bytecomp/translcore.cmi + typing/typedtree.cmi bytecomp/transltyrepr.cmi bytecomp/translobj.cmi \ + typing/primitive.cmi typing/predef.cmi typing/path.cmi utils/misc.cmi \ + bytecomp/matching.cmi parsing/location.cmi bytecomp/lambda.cmi \ + typing/ident.cmi typing/env.cmi utils/config.cmi utils/clflags.cmi \ + typing/btype.cmi parsing/asttypes.cmi bytecomp/translcore.cmi bytecomp/translcore.cmx: typing/types.cmx bytecomp/typeopt.cmx \ - typing/typedtree.cmx bytecomp/translobj.cmx typing/primitive.cmx \ - typing/predef.cmx typing/path.cmx utils/misc.cmx bytecomp/matching.cmx \ - parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \ - utils/config.cmx utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ - bytecomp/translcore.cmi + typing/typedtree.cmx bytecomp/transltyrepr.cmx bytecomp/translobj.cmx \ + typing/primitive.cmx typing/predef.cmx typing/path.cmx utils/misc.cmx \ + bytecomp/matching.cmx parsing/location.cmx bytecomp/lambda.cmx \ + typing/ident.cmx typing/env.cmx utils/config.cmx utils/clflags.cmx \ + typing/btype.cmx parsing/asttypes.cmi bytecomp/translcore.cmi bytecomp/translmod.cmo: typing/types.cmi typing/typedtree.cmi \ - bytecomp/translobj.cmi bytecomp/translcore.cmi bytecomp/translclass.cmi \ - typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \ - typing/path.cmi typing/mtype.cmi utils/misc.cmi parsing/longident.cmi \ - parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \ - typing/ctype.cmi parsing/asttypes.cmi bytecomp/translmod.cmi + bytecomp/transltyrepr.cmi bytecomp/translobj.cmi bytecomp/translcore.cmi \ + bytecomp/translclass.cmi typing/printtyp.cmi typing/primitive.cmi \ + typing/predef.cmi typing/path.cmi typing/mtype.cmi utils/misc.cmi \ + parsing/longident.cmi parsing/location.cmi bytecomp/lambda.cmi \ + typing/ident.cmi typing/env.cmi typing/ctype.cmi parsing/asttypes.cmi \ + bytecomp/translmod.cmi bytecomp/translmod.cmx: typing/types.cmx typing/typedtree.cmx \ - bytecomp/translobj.cmx bytecomp/translcore.cmx bytecomp/translclass.cmx \ - typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \ - typing/path.cmx typing/mtype.cmx utils/misc.cmx parsing/longident.cmx \ - parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \ - typing/ctype.cmx parsing/asttypes.cmi bytecomp/translmod.cmi + bytecomp/transltyrepr.cmx bytecomp/translobj.cmx bytecomp/translcore.cmx \ + bytecomp/translclass.cmx typing/printtyp.cmx typing/primitive.cmx \ + typing/predef.cmx typing/path.cmx typing/mtype.cmx utils/misc.cmx \ + parsing/longident.cmx parsing/location.cmx bytecomp/lambda.cmx \ + typing/ident.cmx typing/env.cmx typing/ctype.cmx parsing/asttypes.cmi \ + bytecomp/translmod.cmi bytecomp/translobj.cmo: typing/primitive.cmi utils/misc.cmi \ parsing/longident.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \ utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ @@ -426,6 +434,14 @@ parsing/longident.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \ utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ bytecomp/translobj.cmi +bytecomp/transltyrepr.cmo: typing/types.cmi typing/predef.cmi typing/path.cmi \ + utils/misc.cmi parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \ + typing/env.cmi typing/ctype.cmi utils/clflags.cmi typing/btype.cmi \ + parsing/asttypes.cmi bytecomp/transltyrepr.cmi +bytecomp/transltyrepr.cmx: typing/types.cmx typing/predef.cmx typing/path.cmx \ + utils/misc.cmx parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx \ + typing/env.cmx typing/ctype.cmx utils/clflags.cmx typing/btype.cmx \ + parsing/asttypes.cmi bytecomp/transltyrepr.cmi bytecomp/typeopt.cmo: typing/types.cmi typing/typedtree.cmi \ typing/primitive.cmi typing/predef.cmi typing/path.cmi utils/misc.cmi \ bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \ @@ -439,8 +455,8 @@ asmcomp/clambda.cmi: bytecomp/lambda.cmi typing/ident.cmi \ parsing/asttypes.cmi asmcomp/closure.cmi: bytecomp/lambda.cmi asmcomp/clambda.cmi -asmcomp/cmm.cmi: typing/ident.cmi asmcomp/cmmgen.cmi: asmcomp/cmm.cmi asmcomp/clambda.cmi +asmcomp/cmm.cmi: typing/ident.cmi asmcomp/codegen.cmi: asmcomp/cmm.cmi asmcomp/comballoc.cmi: asmcomp/mach.cmi asmcomp/compilenv.cmi: typing/ident.cmi asmcomp/clambda.cmi @@ -454,8 +470,8 @@ asmcomp/printmach.cmi: asmcomp/reg.cmi asmcomp/mach.cmi asmcomp/proc.cmi: asmcomp/reg.cmi asmcomp/mach.cmi asmcomp/reg.cmi: asmcomp/cmm.cmi -asmcomp/reload.cmi: asmcomp/mach.cmi asmcomp/reloadgen.cmi: asmcomp/reg.cmi asmcomp/mach.cmi +asmcomp/reload.cmi: asmcomp/mach.cmi asmcomp/schedgen.cmi: asmcomp/mach.cmi asmcomp/linearize.cmi asmcomp/scheduling.cmi: asmcomp/linearize.cmi asmcomp/selectgen.cmi: utils/tbl.cmi asmcomp/reg.cmi asmcomp/mach.cmi \ @@ -463,8 +479,6 @@ asmcomp/selection.cmi: asmcomp/mach.cmi asmcomp/cmm.cmi asmcomp/spill.cmi: asmcomp/mach.cmi asmcomp/split.cmi: asmcomp/mach.cmi -asmcomp/arch.cmo: utils/misc.cmi -asmcomp/arch.cmx: utils/misc.cmx asmcomp/asmgen.cmo: asmcomp/split.cmi asmcomp/spill.cmi asmcomp/selection.cmi \ asmcomp/scheduling.cmi asmcomp/reload.cmi asmcomp/reg.cmi \ asmcomp/proc.cmi asmcomp/printmach.cmi asmcomp/printlinear.cmi \ @@ -519,8 +533,6 @@ utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx asmcomp/compilenv.cmx \ utils/clflags.cmx asmcomp/clambda.cmx parsing/asttypes.cmi \ asmcomp/closure.cmi -asmcomp/cmm.cmo: typing/ident.cmi asmcomp/arch.cmo asmcomp/cmm.cmi -asmcomp/cmm.cmx: typing/ident.cmx asmcomp/arch.cmx asmcomp/cmm.cmi asmcomp/cmmgen.cmo: typing/types.cmi bytecomp/switch.cmi asmcomp/proc.cmi \ typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi \ utils/config.cmi asmcomp/compilenv.cmi asmcomp/cmm.cmi utils/clflags.cmi \ @@ -531,6 +543,8 @@ utils/config.cmx asmcomp/compilenv.cmx asmcomp/cmm.cmx utils/clflags.cmx \ asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/arch.cmx \ asmcomp/cmmgen.cmi +asmcomp/cmm.cmo: typing/ident.cmi asmcomp/arch.cmo asmcomp/cmm.cmi +asmcomp/cmm.cmx: typing/ident.cmx asmcomp/arch.cmx asmcomp/cmm.cmi asmcomp/codegen.cmo: asmcomp/split.cmi asmcomp/spill.cmi asmcomp/reload.cmi \ asmcomp/reg.cmi asmcomp/printmach.cmi asmcomp/printlinear.cmi \ asmcomp/printcmm.cmi asmcomp/liveness.cmi asmcomp/linearize.cmi \ @@ -551,16 +565,16 @@ utils/config.cmi asmcomp/clambda.cmi asmcomp/compilenv.cmi asmcomp/compilenv.cmx: utils/misc.cmx typing/ident.cmx typing/env.cmx \ utils/config.cmx asmcomp/clambda.cmx asmcomp/compilenv.cmi -asmcomp/emit.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ - asmcomp/mach.cmi parsing/location.cmi asmcomp/linearize.cmi \ - asmcomp/emitaux.cmi utils/config.cmi asmcomp/compilenv.cmi \ - asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/emit.cmi -asmcomp/emit.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ - asmcomp/mach.cmx parsing/location.cmx asmcomp/linearize.cmx \ - asmcomp/emitaux.cmx utils/config.cmx asmcomp/compilenv.cmx \ - asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/emit.cmi asmcomp/emitaux.cmo: asmcomp/emitaux.cmi asmcomp/emitaux.cmx: asmcomp/emitaux.cmi +asmcomp/emit.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ + asmcomp/mach.cmi asmcomp/linearize.cmi asmcomp/emitaux.cmi \ + utils/config.cmi asmcomp/compilenv.cmi asmcomp/cmm.cmi utils/clflags.cmi \ + asmcomp/arch.cmo asmcomp/emit.cmi +asmcomp/emit.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ + asmcomp/mach.cmx asmcomp/linearize.cmx asmcomp/emitaux.cmx \ + utils/config.cmx asmcomp/compilenv.cmx asmcomp/cmm.cmx utils/clflags.cmx \ + asmcomp/arch.cmx asmcomp/emit.cmi asmcomp/interf.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ asmcomp/mach.cmi asmcomp/interf.cmi asmcomp/interf.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ @@ -588,39 +602,39 @@ asmcomp/printmach.cmx: asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printcmm.cmx \ asmcomp/mach.cmx asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/printmach.cmi asmcomp/proc.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ - utils/config.cmi asmcomp/cmm.cmi utils/clflags.cmi utils/ccomp.cmi \ - asmcomp/arch.cmo asmcomp/proc.cmi + asmcomp/cmm.cmi utils/ccomp.cmi asmcomp/arch.cmo asmcomp/proc.cmi asmcomp/proc.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ - utils/config.cmx asmcomp/cmm.cmx utils/clflags.cmx utils/ccomp.cmx \ - asmcomp/arch.cmx asmcomp/proc.cmi + asmcomp/cmm.cmx utils/ccomp.cmx asmcomp/arch.cmx asmcomp/proc.cmi asmcomp/reg.cmo: asmcomp/cmm.cmi asmcomp/reg.cmi asmcomp/reg.cmx: asmcomp/cmm.cmx asmcomp/reg.cmi -asmcomp/reload.cmo: asmcomp/reloadgen.cmi asmcomp/reload.cmi -asmcomp/reload.cmx: asmcomp/reloadgen.cmx asmcomp/reload.cmi asmcomp/reloadgen.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ asmcomp/reloadgen.cmi asmcomp/reloadgen.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ asmcomp/reloadgen.cmi +asmcomp/reload.cmo: asmcomp/reloadgen.cmi asmcomp/reg.cmi asmcomp/mach.cmi \ + asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/reload.cmi +asmcomp/reload.cmx: asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \ + asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/reload.cmi asmcomp/schedgen.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ asmcomp/linearize.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \ asmcomp/schedgen.cmi asmcomp/schedgen.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ asmcomp/linearize.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ asmcomp/schedgen.cmi -asmcomp/scheduling.cmo: asmcomp/schedgen.cmi asmcomp/mach.cmi \ - asmcomp/arch.cmo asmcomp/scheduling.cmi -asmcomp/scheduling.cmx: asmcomp/schedgen.cmx asmcomp/mach.cmx \ - asmcomp/arch.cmx asmcomp/scheduling.cmi +asmcomp/scheduling.cmo: asmcomp/schedgen.cmi asmcomp/scheduling.cmi +asmcomp/scheduling.cmx: asmcomp/schedgen.cmx asmcomp/scheduling.cmi asmcomp/selectgen.cmo: utils/tbl.cmi asmcomp/reg.cmi asmcomp/proc.cmi \ utils/misc.cmi asmcomp/mach.cmi typing/ident.cmi asmcomp/cmm.cmi \ asmcomp/arch.cmo asmcomp/selectgen.cmi asmcomp/selectgen.cmx: utils/tbl.cmx asmcomp/reg.cmx asmcomp/proc.cmx \ utils/misc.cmx asmcomp/mach.cmx typing/ident.cmx asmcomp/cmm.cmx \ asmcomp/arch.cmx asmcomp/selectgen.cmi -asmcomp/selection.cmo: asmcomp/selectgen.cmi asmcomp/reg.cmi utils/misc.cmi \ - asmcomp/mach.cmi asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/selection.cmi -asmcomp/selection.cmx: asmcomp/selectgen.cmx asmcomp/reg.cmx utils/misc.cmx \ - asmcomp/mach.cmx asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/selection.cmi +asmcomp/selection.cmo: asmcomp/selectgen.cmi asmcomp/reg.cmi asmcomp/proc.cmi \ + utils/misc.cmi asmcomp/mach.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \ + asmcomp/selection.cmi +asmcomp/selection.cmx: asmcomp/selectgen.cmx asmcomp/reg.cmx asmcomp/proc.cmx \ + utils/misc.cmx asmcomp/mach.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ + asmcomp/selection.cmi asmcomp/spill.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ asmcomp/mach.cmi asmcomp/spill.cmi asmcomp/spill.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ @@ -647,18 +661,22 @@ bytecomp/bytegen.cmx driver/compile.cmi driver/errors.cmo: utils/warnings.cmi typing/typetexp.cmi typing/typemod.cmi \ typing/typedecl.cmi typing/typecore.cmi typing/typeclass.cmi \ - bytecomp/translmod.cmi bytecomp/translcore.cmi bytecomp/translclass.cmi \ - parsing/syntaxerr.cmi bytecomp/symtable.cmi driver/pparse.cmi \ - parsing/location.cmi parsing/lexer.cmi typing/includemod.cmi \ - typing/env.cmi typing/ctype.cmi bytecomp/bytepackager.cmi \ - bytecomp/bytelink.cmi bytecomp/bytelibrarian.cmi driver/errors.cmi + bytecomp/transltyrepr.cmi bytecomp/translmod.cmi bytecomp/translcore.cmi \ + bytecomp/translclass.cmi parsing/syntaxerr.cmi bytecomp/symtable.cmi \ + driver/pparse.cmi parsing/location.cmi parsing/lexer.cmi \ + typing/includemod.cmi typing/env.cmi typing/ctype.cmi \ + bytecomp/bytepackager.cmi bytecomp/bytelink.cmi \ + bytecomp/bytelibrarian.cmi driver/errors.cmi driver/errors.cmx: utils/warnings.cmx typing/typetexp.cmx typing/typemod.cmx \ typing/typedecl.cmx typing/typecore.cmx typing/typeclass.cmx \ - bytecomp/translmod.cmx bytecomp/translcore.cmx bytecomp/translclass.cmx \ - parsing/syntaxerr.cmx bytecomp/symtable.cmx driver/pparse.cmx \ - parsing/location.cmx parsing/lexer.cmx typing/includemod.cmx \ - typing/env.cmx typing/ctype.cmx bytecomp/bytepackager.cmx \ - bytecomp/bytelink.cmx bytecomp/bytelibrarian.cmx driver/errors.cmi + bytecomp/transltyrepr.cmx bytecomp/translmod.cmx bytecomp/translcore.cmx \ + bytecomp/translclass.cmx parsing/syntaxerr.cmx bytecomp/symtable.cmx \ + driver/pparse.cmx parsing/location.cmx parsing/lexer.cmx \ + typing/includemod.cmx typing/env.cmx typing/ctype.cmx \ + bytecomp/bytepackager.cmx bytecomp/bytelink.cmx \ + bytecomp/bytelibrarian.cmx driver/errors.cmi +driver/main_args.cmo: driver/main_args.cmi +driver/main_args.cmx: driver/main_args.cmi driver/main.cmo: utils/warnings.cmi utils/misc.cmi driver/main_args.cmi \ driver/errors.cmi utils/config.cmi driver/compile.cmi utils/clflags.cmi \ bytecomp/bytepackager.cmi bytecomp/bytelink.cmi \ @@ -667,8 +685,6 @@ driver/errors.cmx utils/config.cmx driver/compile.cmx utils/clflags.cmx \ bytecomp/bytepackager.cmx bytecomp/bytelink.cmx \ bytecomp/bytelibrarian.cmx driver/main.cmi -driver/main_args.cmo: driver/main_args.cmi -driver/main_args.cmx: driver/main_args.cmi driver/optcompile.cmo: utils/warnings.cmi typing/unused_var.cmi \ typing/typemod.cmi typing/typedtree.cmi bytecomp/translmod.cmi \ bytecomp/simplif.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \ @@ -685,20 +701,20 @@ driver/optcompile.cmi driver/opterrors.cmo: utils/warnings.cmi typing/typetexp.cmi \ typing/typemod.cmi typing/typedecl.cmi typing/typecore.cmi \ - typing/typeclass.cmi bytecomp/translmod.cmi bytecomp/translcore.cmi \ - bytecomp/translclass.cmi parsing/syntaxerr.cmi driver/pparse.cmi \ - parsing/location.cmi parsing/lexer.cmi typing/includemod.cmi \ - typing/env.cmi typing/ctype.cmi asmcomp/compilenv.cmi \ - asmcomp/asmpackager.cmi asmcomp/asmlink.cmi asmcomp/asmlibrarian.cmi \ - asmcomp/asmgen.cmi driver/opterrors.cmi + typing/typeclass.cmi bytecomp/transltyrepr.cmi bytecomp/translmod.cmi \ + bytecomp/translcore.cmi bytecomp/translclass.cmi parsing/syntaxerr.cmi \ + driver/pparse.cmi parsing/location.cmi parsing/lexer.cmi \ + typing/includemod.cmi typing/env.cmi typing/ctype.cmi \ + asmcomp/compilenv.cmi asmcomp/asmpackager.cmi asmcomp/asmlink.cmi \ + asmcomp/asmlibrarian.cmi asmcomp/asmgen.cmi driver/opterrors.cmi driver/opterrors.cmx: utils/warnings.cmx typing/typetexp.cmx \ typing/typemod.cmx typing/typedecl.cmx typing/typecore.cmx \ - typing/typeclass.cmx bytecomp/translmod.cmx bytecomp/translcore.cmx \ - bytecomp/translclass.cmx parsing/syntaxerr.cmx driver/pparse.cmx \ - parsing/location.cmx parsing/lexer.cmx typing/includemod.cmx \ - typing/env.cmx typing/ctype.cmx asmcomp/compilenv.cmx \ - asmcomp/asmpackager.cmx asmcomp/asmlink.cmx asmcomp/asmlibrarian.cmx \ - asmcomp/asmgen.cmx driver/opterrors.cmi + typing/typeclass.cmx bytecomp/transltyrepr.cmx bytecomp/translmod.cmx \ + bytecomp/translcore.cmx bytecomp/translclass.cmx parsing/syntaxerr.cmx \ + driver/pparse.cmx parsing/location.cmx parsing/lexer.cmx \ + typing/includemod.cmx typing/env.cmx typing/ctype.cmx \ + asmcomp/compilenv.cmx asmcomp/asmpackager.cmx asmcomp/asmlink.cmx \ + asmcomp/asmlibrarian.cmx asmcomp/asmgen.cmx driver/opterrors.cmi driver/optmain.cmo: utils/warnings.cmi asmcomp/printmach.cmi \ driver/opterrors.cmi driver/optcompile.cmi utils/misc.cmi \ utils/config.cmi utils/clflags.cmi asmcomp/asmpackager.cmi \ diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/driver/errors.ml ocaml/driver/errors.ml --- ocaml.cvs/driver/errors.ml 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/driver/errors.ml 2006-03-28 23:25:53.000000000 +0200 @@ -46,6 +46,8 @@ Includemod.report_error ppf err | Typemod.Error(loc, err) -> Location.print ppf loc; Typemod.report_error ppf err + | Transltyrepr.Error(loc, err) -> + Location.print ppf loc; Transltyrepr.report_error ppf err | Translcore.Error(loc, err) -> Location.print ppf loc; Translcore.report_error ppf err | Translclass.Error(loc, err) -> diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/driver/opterrors.ml ocaml/driver/opterrors.ml --- ocaml.cvs/driver/opterrors.ml 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/driver/opterrors.ml 2006-03-28 23:25:53.000000000 +0200 @@ -48,6 +48,8 @@ Location.print ppf loc; Typemod.report_error ppf err | Translcore.Error(loc, err) -> Location.print ppf loc; Translcore.report_error ppf err + | Transltyrepr.Error(loc, err) -> + Location.print ppf loc; Transltyrepr.report_error ppf err | Translclass.Error(loc, err) -> Location.print ppf loc; Translclass.report_error ppf err | Translmod.Error(loc, err) -> diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/Makefile ocaml/Makefile --- ocaml.cvs/Makefile 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/Makefile 2006-03-29 00:58:07.000000000 +0200 @@ -19,7 +19,7 @@ CAMLC=boot/ocamlrun boot/ocamlc -nostdlib -I boot CAMLOPT=boot/ocamlrun ./ocamlopt -nostdlib -I stdlib -COMPFLAGS=-warn-error A $(INCLUDES) +COMPFLAGS=-warn-error A $(INCLUDES) -noty LINKFLAGS= CAMLYACC=boot/ocamlyacc @@ -59,7 +59,7 @@ COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \ bytecomp/typeopt.cmo bytecomp/switch.cmo bytecomp/matching.cmo \ - bytecomp/translobj.cmo bytecomp/translcore.cmo \ + bytecomp/translobj.cmo bytecomp/transltyrepr.cmo bytecomp/translcore.cmo \ bytecomp/translclass.cmo bytecomp/translmod.cmo \ bytecomp/simplif.cmo bytecomp/runtimedef.cmo @@ -105,6 +105,8 @@ EXPUNGEOBJS=utils/misc.cmo utils/tbl.cmo \ utils/config.cmo utils/clflags.cmo \ + utils/terminfo.cmo utils/warnings.cmo \ + parsing/linenum.cmo parsing/location.cmo \ typing/ident.cmo typing/path.cmo typing/types.cmo typing/btype.cmo \ typing/predef.cmo bytecomp/runtimedef.cmo bytecomp/bytesections.cmo \ bytecomp/dll.cmo bytecomp/meta.cmo bytecomp/symtable.cmo toplevel/expunge.cmo @@ -507,7 +509,7 @@ clean:: cd byterun; $(MAKE) clean rm -f stdlib/libcamlrun.a - rm -f stdlib/caml + rm -rf stdlib/caml alldepend:: cd byterun; $(MAKE) depend diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/ocamldoc/Makefile ocaml/ocamldoc/Makefile --- ocaml.cvs/ocamldoc/Makefile 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/ocamldoc/Makefile 2006-10-09 18:12:34.000000000 +0200 @@ -175,6 +175,7 @@ $(OCAMLSRCDIR)/bytecomp/switch.cmo \ $(OCAMLSRCDIR)/bytecomp/matching.cmo \ $(OCAMLSRCDIR)/bytecomp/translobj.cmo \ + $(OCAMLSRCDIR)/bytecomp/transltyrepr.cmo \ $(OCAMLSRCDIR)/bytecomp/translcore.cmo \ $(OCAMLSRCDIR)/bytecomp/translclass.cmo \ $(OCAMLSRCDIR)/tools/depend.cmo diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/otherlibs/dynlink/Makefile ocaml/otherlibs/dynlink/Makefile --- ocaml.cvs/otherlibs/dynlink/Makefile 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/otherlibs/dynlink/Makefile 2006-03-28 23:25:54.000000000 +0200 @@ -18,12 +18,13 @@ include ../../config/Makefile CAMLC=../../boot/ocamlrun ../../ocamlc -INCLUDES=-I ../../utils -I ../../typing -I ../../bytecomp +INCLUDES=-I ../../utils -I ../../parsing -I ../../typing -I ../../bytecomp COMPFLAGS=-warn-error A -I ../../stdlib $(INCLUDES) OBJS=dynlink.cmo COMPILEROBJS=misc.cmo config.cmo tbl.cmo clflags.cmo consistbl.cmo \ ident.cmo path.cmo \ + terminfo.cmo warnings.cmo linenum.cmo location.cmo \ types.cmo btype.cmo predef.cmo runtimedef.cmo \ bytesections.cmo dll.cmo meta.cmo symtable.cmo opcodes.cmo diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/otherlibs/labltk/browser/searchpos.ml ocaml/otherlibs/labltk/browser/searchpos.ml --- ocaml.cvs/otherlibs/labltk/browser/searchpos.ml 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/otherlibs/labltk/browser/searchpos.ml 2006-03-28 23:25:54.000000000 +0200 @@ -813,6 +813,7 @@ search_pos_expr exp ~pos | Texp_object (cls, _, _) -> search_pos_class_structure ~pos cls + | Texp_tyrepr _ -> () (* TODO *) end; add_found_str (`Exp(`Expr, exp.exp_type)) ~env:exp.exp_env ~loc:exp.exp_loc end diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/otherlibs/safe_unmarshaling/check.ml ocaml/otherlibs/safe_unmarshaling/check.ml --- ocaml.cvs/otherlibs/safe_unmarshaling/check.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml/otherlibs/safe_unmarshaling/check.ml 2006-10-09 22:10:36.000000000 +0200 @@ -0,0 +1,135 @@ +open ObjHelpers +open Ty +open Sharing +open TopologicalSort +module Stack = StackBis + +let custom_nativeint_tag = (Obj.field (Obj.repr Nativeint.zero) 0) +let custom_int32_tag = (Obj.field (Obj.repr Int32.zero) 0) +let custom_int64_tag = (Obj.field (Obj.repr Int64.zero) 0) + +let custom_nativeint_size = 2 +let custom_int32_size = 2 +let custom_int64_size = 1 + 64 / Sys.word_size + + +let accumulate_ty sh ty = + match sh.ty with + | None -> sh.ty <- Some ty + | Some ty' -> sh.ty <- Some (Ty.antiunif ty' ty) + +let unoption = function (Some t) -> t | None -> assert false + +let check obj ty = + + let _ = (obj : Obj.t) in + + let shared = Sharing.alloc_table obj + and stack = Stack.create () + and current_scc = ref 0 + and postponed = ref [] in + + let rec check_obj obj ty = + if Obj.is_int obj then check_int (Obj.obj obj) ty + else if not (ObjMap.mem obj shared) then check_block obj ty + else check_shared (ObjMap.find obj shared) ty + + and check_int i ty = + match Ty.repr ty with + | Tint -> true + | Tunit | Tlist _ | Toption _ -> i = 0 + | Tbool -> i = 0 || i = 1 + | Tchar -> 0 <= i && i < 256 + | Tsum (const, _) -> 0 <= i && i < Array.length const + | Tvariant _ -> assert false (* TODO *) + | _ -> false + + and check_block obj ty = + let tag = Obj.tag obj + and size = Obj.size obj in + match Ty.repr ty with + | Tstring -> tag = Obj.string_tag + | Tfloat -> tag = Obj.double_tag + (* | Tfloat -> tag = Obj.double_array_tag || (size = 0 && tag = 0) *) + | Toption ty when tag = 0 && size = 1-> check_obj (Obj.field obj 0) ty + | Tlist ty' when tag = 0 && size = 2 -> + check_obj (Obj.field obj 0) ty' && check_obj (Obj.field obj 1) ty + | Ttuple tys when size = Array.length tys -> + ObjHelpers.for_all2 check_obj obj tys + | Tdoublerecord names when tag = Obj.double_array_tag -> + size = Array.length names + | Tsum (_,nconst) when tag < Array.length nconst -> + let tys = snd nconst.(tag) in + Array.length tys = size && ObjHelpers.for_all2 check_obj obj tys + | Trecord ntys when tag = 0 -> + Array.length ntys = size && + ObjHelpers.for_all2 + (fun obj (_,mut,ty) -> + let ty = cut_head_quantification ty in + if mut && not (is_monomorphic ty) then false + else check_obj obj ty) + obj ntys + | Tvariant _ -> assert false (* TODO *) + | Tnativeint -> + tag = Obj.custom_tag && size = custom_nativeint_size && + ((Obj.field obj 0) == custom_nativeint_tag) + | Tint32 -> + tag = Obj.custom_tag && size = custom_int32_size && + ((Obj.field obj 0) == custom_int32_tag) + | Tint64 -> + tag = Obj.custom_tag && size = custom_int64_size && + ((Obj.field obj 0) == custom_int64_tag) + | _ -> false + + and check_shared sh ty = + sh.remaining <- sh.remaining - 1; + if sh.remaining < 0 then Ty.instance ty (unoption sh.ty) + else begin + accumulate_ty sh ty; + sh.scc_id != !current_scc || + if sh.remaining = 0 + then check_block sh.value (unoption sh.ty) + else (postponed := sh :: !postponed; true) + end + in + + let check_scc scc = + (* Check type for a scc. Due to topological sorting, each node + with types informations are roots. We mark them with 0 in the + "remaining" field. *) + current_scc := (List.hd scc).scc_id; + List.iter (fun sh -> if sh.ty <> None then sh.remaining <- 0) scc; + List.for_all + (fun sh -> match sh.ty with + | None -> true + | Some ty -> check_block sh.value ty) + scc + in + + let have_found_cycle () = + (* predicate with side-effects ... *) + postponed := List.filter (fun sh -> sh.remaining > 0) !postponed; + if !postponed <> [] then + let sccs = List.rev (sort shared !current_scc !postponed) in + List.iter (fun scc -> Stack.push scc stack) sccs; + postponed := []; + true + else false + in + + (* + let rec check_cycle () = + (not (have_found_cycle ()) && Stack.is_empty stack) || + (check_scc (Stack.pop stack) && check_cycle ()) in + + check_obj obj ty && check_cycle () + *) + + let result = ref (check_obj obj ty) in + + while !result && (have_found_cycle () || not (Stack.is_empty stack)) do + result := check_scc (Stack.pop stack) + done; + + !result + diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/otherlibs/safe_unmarshaling/.depend ocaml/otherlibs/safe_unmarshaling/.depend --- ocaml.cvs/otherlibs/safe_unmarshaling/.depend 1970-01-01 01:00:00.000000000 +0100 +++ ocaml/otherlibs/safe_unmarshaling/.depend 2006-05-11 19:36:04.000000000 +0200 @@ -0,0 +1,14 @@ +check.cmo: topologicalSort.cmo lib/stackBis.cmo sharing.cmo \ + lib/objHelpers.cmi +check.cmx: topologicalSort.cmx lib/stackBis.cmx sharing.cmx \ + lib/objHelpers.cmx +safeUnmarshal.cmo: check.cmo safeUnmarshal.cmi +safeUnmarshal.cmx: check.cmx safeUnmarshal.cmi +sharing.cmo: lib/objHelpers.cmi +sharing.cmx: lib/objHelpers.cmx +test.cmo: check.cmo +test.cmx: check.cmx +topologicalSort.cmo: lib/stackBis.cmo sharing.cmo lib/objHelpers.cmi +topologicalSort.cmx: lib/stackBis.cmx sharing.cmx lib/objHelpers.cmx +lib/objHelpers.cmo: lib/objHelpers.cmi +lib/objHelpers.cmx: lib/objHelpers.cmi diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/otherlibs/safe_unmarshaling/lib/arrayHelpers.ml ocaml/otherlibs/safe_unmarshaling/lib/arrayHelpers.ml --- ocaml.cvs/otherlibs/safe_unmarshaling/lib/arrayHelpers.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml/otherlibs/safe_unmarshaling/lib/arrayHelpers.ml 2006-03-29 03:09:54.000000000 +0200 @@ -0,0 +1,10 @@ +let for_all f a = + let size = Array.length a in + let rec loop i = + i >= size || (f a.(i) && loop (succ i)) in + loop 0 +let for_all2 f a b = + let size = Array.length a in + let rec loop i = + i >= size || (f a.(i) b.(i) && loop (succ i)) in + loop 0 diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/otherlibs/safe_unmarshaling/lib/objHelpers.ml ocaml/otherlibs/safe_unmarshaling/lib/objHelpers.ml --- ocaml.cvs/otherlibs/safe_unmarshaling/lib/objHelpers.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml/otherlibs/safe_unmarshaling/lib/objHelpers.ml 2006-05-24 06:39:34.000000000 +0200 @@ -0,0 +1,66 @@ +(** Utilitaires *) + +(** Itérateur sur Obj.t *) +let fold_left f init t = + if Obj.is_int t || (Obj.tag t) >= Obj.no_scan_tag then + init + else + let max = Obj.size t in + let rec loop acc i = + if i < max then + loop (f acc (Obj.field t i)) (succ i) + else + acc in + loop init 0 + +(** Itérateur sur Obj.t *) +let fold_right f init t = + if Obj.is_int t || (Obj.tag t) >= Obj.no_scan_tag then + init + else + let max = Obj.size t in + let rec loop acc i = + if i >= 0 then + loop (f acc (Obj.field t i)) (pred i) + else + acc in + loop init (pred max) + +(** Itérateur sur Obj.t *) +let for_all2 f obj a = + let size = Obj.size obj in + let rec loop i = + i >= size || (f (Obj.field obj i) a.(i) && loop (succ i)) in + loop 0 + +(** Structure de donnée ordonnée : Set, Map, ... *) +module OrderedObj = + struct + type t = Obj.t + let compare : t -> t -> int = Obj.magic (-) + end +module ObjSet = Set.Make (OrderedObj) +module ObjMap = + (* Map.Make (OrderedObj) ... mieux vaut pas si les objets sont déplaçable ! *) + struct + type key = Obj.t + + type 'a t = (key * 'a) list + + let empty = [] + + let is_empty = function [] -> true | _ -> false + + let add x data m = (x, data) :: m + let find x m = List.assq x m + let mem x m = List.mem_assq x m + let remove x m = List.remove_assq x m + let iter f m = List.iter (fun (x, data) -> f x data) m + let map f m = List.map (fun (x, data) -> (x,f data)) m + let mapi f m = List.map (fun (x, data) -> (x,f x data)) m + let fold f m accu = List.fold_left (fun accu (x, data) -> f x data accu) accu m + let compare cmp m1 m2 = -1 + let equal cmp m1 m2 = false + +end + diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/otherlibs/safe_unmarshaling/lib/objHelpers.mli ocaml/otherlibs/safe_unmarshaling/lib/objHelpers.mli --- ocaml.cvs/otherlibs/safe_unmarshaling/lib/objHelpers.mli 1970-01-01 01:00:00.000000000 +0100 +++ ocaml/otherlibs/safe_unmarshaling/lib/objHelpers.mli 2006-03-29 03:09:54.000000000 +0200 @@ -0,0 +1,7 @@ +open Obj + +val for_all2 : (t -> 'a -> bool) -> t -> 'a array -> bool +val fold_left : ('a -> t -> 'a) -> 'a -> t -> 'a +val fold_right : ('a -> t -> 'a) -> 'a -> t -> 'a + +module ObjMap : Map.S with type key = t diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/otherlibs/safe_unmarshaling/lib/stackBis.ml ocaml/otherlibs/safe_unmarshaling/lib/stackBis.ml --- ocaml.cvs/otherlibs/safe_unmarshaling/lib/stackBis.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml/otherlibs/safe_unmarshaling/lib/stackBis.ml 2006-03-29 03:09:54.000000000 +0200 @@ -0,0 +1,18 @@ +(*s Bla bla + *) + +let create () = ref [] + +let push sh stack = + stack := sh :: !stack + +let pop stack = + match !stack with + | [] -> raise Not_found + | hd::tl -> stack := tl; hd + +let is_empty stack = + !stack = [] + +let in_stack sh stack = + List.memq sh !stack diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/otherlibs/safe_unmarshaling/Makefile ocaml/otherlibs/safe_unmarshaling/Makefile --- ocaml.cvs/otherlibs/safe_unmarshaling/Makefile 1970-01-01 01:00:00.000000000 +0100 +++ ocaml/otherlibs/safe_unmarshaling/Makefile 2006-06-22 02:41:27.000000000 +0200 @@ -0,0 +1,63 @@ +include ../../config/Makefile + +# Compilation options +OCAML=../../byterun/ocamlrun ../../ocaml -I ../../stdlib +CAMLC=../../ocamlcomp.sh -I lib +CAMLOPT=../../ocamlcompopt.sh -I lib +COMPFLAGS=-warn-error A +MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib -custom + +MODULES = lib/objHelpers lib/arrayHelpers lib/stackBis \ + sharing topologicalSort check safeUnmarshal +CMO = ${addsuffix .cmo,${MODULES}} +CMX = ${addsuffix .cmx,${MODULES}} + +all: safeUnmarshal.cma + +allopt: safeUnmarshal.cmxa + +safeUnmarshal.cma: ${CMO} + $(CAMLC) -a -o safeUnmarshal.cma ${CMO} +# $(MKLIB) -ocamlc '$(CAMLC)' -o safeUnmarshal ${CMO} + +safeUnmarshal.cmxa: ${CMX} + $(CAMLOPT) -a -o safeUnmarshal.cmxa ${CMX} +# $(MKLIB) -ocamlopt '$(CAMLOPT)' -o safeUnmarshal ${CMX} + +partialclean: + rm -f *.cm* lib/*.cm* + +clean: partialclean + rm -f .history + +install: + cp safeUnmarshal.cma safeUnmarshal.cmi safeUnmarshal.mli $(LIBDIR) + +installopt: + cp safeUnmarshal.cmxa safeUnmarshal.a $(LIBDIR) + +.SUFFIXES: .ml .mli .cmo .cmi .cmx + +.mli.cmi: + $(CAMLC) -c $(COMPFLAGS) $< + +.ml.cmo: + $(CAMLC) -c $(COMPFLAGS) $< + +.ml.cmx: + $(CAMLOPT) -c $(COMPFLAGS) $< + +depend: + ../../boot/ocamlrun ../../tools/ocamldep -I lib *.mli *.ml lib/*.mli lib/*.ml > .depend + +include .depend + +.PHONY: top toprec + +top: ${CMO} + @echo $(LEDITBIN) + ${OCAML} ${CMO} + +toprec: ${CMO} + ${OCAML} ${CMO} -rectypes + diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/otherlibs/safe_unmarshaling/.ocamlinit ocaml/otherlibs/safe_unmarshaling/.ocamlinit --- ocaml.cvs/otherlibs/safe_unmarshaling/.ocamlinit 1970-01-01 01:00:00.000000000 +0100 +++ ocaml/otherlibs/safe_unmarshaling/.ocamlinit 2006-04-03 09:52:54.000000000 +0200 @@ -0,0 +1,2 @@ +open SafeUnmarshal;; +open Ty;; diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/otherlibs/safe_unmarshaling/safeUnmarshal.ml ocaml/otherlibs/safe_unmarshaling/safeUnmarshal.ml --- ocaml.cvs/otherlibs/safe_unmarshaling/safeUnmarshal.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml/otherlibs/safe_unmarshaling/safeUnmarshal.ml 2006-10-09 22:01:49.000000000 +0200 @@ -0,0 +1,20 @@ + +exception Fail + +let from_string ty s i = + let obj = Marshal.from_string s i in + if Check.check obj (Ty.dump ty) + then obj + else raise Fail + +let from_channel ty ch = + let obj = Marshal.from_channel ch in + if Check.check obj (Ty.dump ty) + then obj + else raise Fail + +let copy ty obj = + from_string ty (Marshal.to_string obj []) 0 + + +let check obj ty = Check.check (Obj.repr obj) (Ty.dump ty) diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/otherlibs/safe_unmarshaling/safeUnmarshal.mli ocaml/otherlibs/safe_unmarshaling/safeUnmarshal.mli --- ocaml.cvs/otherlibs/safe_unmarshaling/safeUnmarshal.mli 1970-01-01 01:00:00.000000000 +0100 +++ ocaml/otherlibs/safe_unmarshaling/safeUnmarshal.mli 2006-10-09 22:01:46.000000000 +0200 @@ -0,0 +1,16 @@ +(** Fonctions de désérialisation sûre. *) + +(** L'exception qui est produite par une fonction de désérialisation + lorsque la valeur à désérialiser est incompatible avec le type + attendu. *) +exception Fail + +(** ... *) +val from_string : 'a tyrepr -> string -> int -> 'a + +(** ... *) +val from_channel : 'a tyrepr -> in_channel -> 'a + +(** ... *) +val copy : 'a tyrepr -> 'b -> 'a +val check : 'a -> 'b tyrepr -> bool diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/otherlibs/safe_unmarshaling/sharing.ml ocaml/otherlibs/safe_unmarshaling/sharing.ml --- ocaml.cvs/otherlibs/safe_unmarshaling/sharing.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml/otherlibs/safe_unmarshaling/sharing.ml 2006-05-24 06:38:44.000000000 +0200 @@ -0,0 +1,47 @@ +open ObjHelpers +open Ty + +(* On construit une liste d'association (Obj.t * shared_block) + en attendant de voir s'il y a mieux à faire *) + +type shared_block = { + value: Obj.t; + references: int; + mutable remaining: int; + mutable ty: Ty.expression option; + + depth: int; + mutable succ: shared_block list option; + mutable scc_id: int; + mutable sort_tag: bool; + + } + +let init_shared_block value references depth = { + value = value ; + references = references ; + remaining = references ; + ty = None ; + + depth = depth ; + succ = None ; + scc_id = 0 ; + sort_tag = false ; + } + +let explore obj = + let cpt = ref 0 in + let rec loop acc value = + try incr (snd (ObjMap.find value acc)); acc + with Not_found -> + if Obj.is_int value then acc + else (incr cpt; ObjHelpers.fold_left loop (ObjMap.add value (!cpt,ref 1) acc) value) in + loop ObjMap.empty obj + +let alloc_table obj = + ObjMap.fold + (fun value (depth, references) acc -> + if !references = 1 then acc + else ObjMap.add value (init_shared_block value !references depth) acc) + (explore obj) + ObjMap.empty diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/otherlibs/safe_unmarshaling/test.ml ocaml/otherlibs/safe_unmarshaling/test.ml --- ocaml.cvs/otherlibs/safe_unmarshaling/test.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml/otherlibs/safe_unmarshaling/test.ml 2006-03-29 03:09:54.000000000 +0200 @@ -0,0 +1,22 @@ +open Ty;; +open Check;; + +check (Obj.repr (let l = None::[] in (l,l))) + (Prod [|List (Option String); List (Option Int)|]);; + +check (Obj.repr (let rec l = 1 ::l in l)) (List Int);; + +let rec a = let c = Some a in (Some c, Some c);; +let obj = Obj.repr a ;; +let rec ty = Prod [| Option (Option ty); Option (Option ty)|];; + +(* +open ObjHelpers;; +let shared = Sharing.explore (Obj.repr a);; +let post = Queue.create ();; +Queue.add (ObjMap.find (Obj.repr a) shared) post;; +let l = TopologicalSort.sort shared 0 post;; +List.length l;; +*) + +check obj ty;; diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/otherlibs/safe_unmarshaling/topologicalSort.ml ocaml/otherlibs/safe_unmarshaling/topologicalSort.ml --- ocaml.cvs/otherlibs/safe_unmarshaling/topologicalSort.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml/otherlibs/safe_unmarshaling/topologicalSort.ml 2006-03-29 03:09:54.000000000 +0200 @@ -0,0 +1,47 @@ +open Sharing +open ObjHelpers +module Stack = StackBis + +let get_shared_succ table sh = + match sh.succ with + | None -> + let rec loop acc obj = + try ObjMap.find obj table :: acc + with Not_found -> + ObjHelpers.fold_left loop acc obj in + let succ = fold_left loop [] sh.value in + sh.succ <- Some succ; succ + | Some succ -> succ + +let get_succ_in_scc table scc_id sh = + List.filter (fun sh -> sh.scc_id = scc_id && sh.remaining > 0) (get_shared_succ table sh) + +let sort table scc_id roots = + let id = ref scc_id + and sccs = ref [] + and stack = Stack.create () + and tagged = not (List.hd roots).sort_tag in + + let found_scc link = + let scc = ref [] in incr id; + let rec loop () = + let sh = Stack.pop stack in + sh.scc_id <- !id; scc := sh :: !scc; + if sh.depth <> link then loop () in + loop (); + sccs := !scc :: !sccs in + + let rec sort sh = + sh.sort_tag <- not sh.sort_tag; + Stack.push sh stack; + let link = List.fold_left + (fun link succ -> + if succ.sort_tag <> tagged then min link (sort succ) + else if Stack.in_stack sh stack then min link succ.depth + else link) + sh.depth (get_succ_in_scc table scc_id sh) in + if link = sh.depth then found_scc link; link in + + List.iter (fun sh -> if sh.sort_tag <> tagged then ignore (sort sh)) + (List.fast_sort (fun x y -> x.depth - y.depth) roots); + !sccs diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/parsing/lexer.mll ocaml/parsing/lexer.mll --- ocaml.cvs/parsing/lexer.mll 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/parsing/lexer.mll 2006-03-28 23:25:55.000000000 +0200 @@ -360,6 +360,7 @@ | "[|" { LBRACKETBAR } | "[<" { LBRACKETLESS } | "[>" { LBRACKETGREATER } + | "[^" { LBRACKETCARET } | "]" { RBRACKET } | "{" { LBRACE } | "{<" { LBRACELESS } @@ -368,6 +369,7 @@ | "|]" { BARRBRACKET } | ">" { GREATER } | ">]" { GREATERRBRACKET } + | "^]" { CARETRBRACKET } | "}" { RBRACE } | ">}" { GREATERRBRACE } diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/parsing/parser.mly ocaml/parsing/parser.mly --- ocaml.cvs/parsing/parser.mly 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/parsing/parser.mly 2006-03-28 23:25:55.000000000 +0200 @@ -203,6 +203,7 @@ %token COLONCOLON %token COLONEQUAL %token COLONGREATER +%token CARETRBRACKET %token COMMA %token CONSTRAINT %token DO @@ -246,6 +247,7 @@ %token LBRACKETBAR %token LBRACKETLESS %token LBRACKETGREATER +%token LBRACKETCARET %token LESS %token LESSMINUS %token LET @@ -354,7 +356,7 @@ %nonassoc DOT /* Finally, the first tokens of simple_expr are above everything else. */ %nonassoc BACKQUOTE BEGIN CHAR FALSE FLOAT INT INT32 INT64 - LBRACE LBRACELESS LBRACKET LBRACKETBAR LIDENT LPAREN + LBRACE LBRACELESS LBRACKET LBRACKETBAR LBRACKETCARET LIDENT LPAREN NEW NATIVEINT PREFIXOP STRING TRUE UIDENT @@ -950,6 +952,10 @@ { unclosed "{<" 1 ">}" 4 } | LBRACELESS GREATERRBRACE { mkexp(Pexp_override []) } + | LBRACKETCARET poly_type CARETRBRACKET + { mkexp(Pexp_tyrepr($2)) } + | LBRACKETCARET poly_type error + { unclosed "[^" 1 "^]" 3 } | simple_expr SHARP label { mkexp(Pexp_send($1, $3)) } ; @@ -1096,6 +1102,8 @@ { mkpat(Ppat_array []) } | LBRACKETBAR pattern_semi_list opt_semi error { unclosed "[|" 1 "|]" 4 } + | LBRACKETCARET core_type error + { unclosed "[^" 1 "^]" 3 } | LPAREN pattern RPAREN { reloc_pat $2 } | LPAREN pattern error diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/parsing/parsetree.mli ocaml/parsing/parsetree.mli --- ocaml.cvs/parsing/parsetree.mli 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/parsing/parsetree.mli 2006-03-28 23:25:55.000000000 +0200 @@ -111,6 +111,7 @@ | Pexp_lazy of expression | Pexp_poly of expression * core_type option | Pexp_object of class_structure + | Pexp_tyrepr of core_type (* Value descriptions *) diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/parsing/printast.ml ocaml/parsing/printast.ml --- ocaml.cvs/parsing/printast.ml 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/parsing/printast.ml 2006-03-28 23:25:55.000000000 +0200 @@ -295,6 +295,9 @@ | Pexp_object s -> line i ppf "Pexp_object"; class_structure i ppf s + | Pexp_tyrepr (ct) -> + line i ppf "Pexp_tyrepr\n"; + core_type i ppf ct; and value_description i ppf x = line i ppf "value_description\n"; diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/stdlib/.depend ocaml/stdlib/.depend --- ocaml.cvs/stdlib/.depend 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/stdlib/.depend 2006-03-28 23:25:55.000000000 +0200 @@ -5,15 +5,15 @@ moreLabels.cmi: set.cmi map.cmi hashtbl.cmi oo.cmi: camlinternalOO.cmi parsing.cmi: obj.cmi lexing.cmi -printf.cmi: buffer.cmi +printf.cmi: obj.cmi buffer.cmi random.cmi: nativeint.cmi int64.cmi int32.cmi weak.cmi: hashtbl.cmi arg.cmo: sys.cmi string.cmi printf.cmi list.cmi buffer.cmi array.cmi arg.cmi arg.cmx: sys.cmx string.cmx printf.cmx list.cmx buffer.cmx array.cmx arg.cmi -array.cmo: array.cmi -array.cmx: array.cmi arrayLabels.cmo: array.cmi arrayLabels.cmi arrayLabels.cmx: array.cmx arrayLabels.cmi +array.cmo: array.cmi +array.cmx: array.cmi buffer.cmo: sys.cmi string.cmi buffer.cmi buffer.cmx: sys.cmx string.cmx buffer.cmi callback.cmo: obj.cmi callback.cmi @@ -50,10 +50,10 @@ lazy.cmx: obj.cmx lazy.cmi lexing.cmo: sys.cmi string.cmi array.cmi lexing.cmi lexing.cmx: sys.cmx string.cmx array.cmx lexing.cmi -list.cmo: list.cmi -list.cmx: list.cmi listLabels.cmo: list.cmi listLabels.cmi listLabels.cmx: list.cmx listLabels.cmi +list.cmo: list.cmi +list.cmx: list.cmi map.cmo: map.cmi map.cmx: map.cmi marshal.cmo: string.cmi marshal.cmi @@ -72,8 +72,10 @@ pervasives.cmx: pervasives.cmi printexc.cmo: printf.cmi obj.cmi printexc.cmi printexc.cmx: printf.cmx obj.cmx printexc.cmi -printf.cmo: string.cmi obj.cmi list.cmi char.cmi buffer.cmi printf.cmi -printf.cmx: string.cmx obj.cmx list.cmx char.cmx buffer.cmx printf.cmi +printf.cmo: string.cmi obj.cmi list.cmi char.cmi buffer.cmi array.cmi \ + printf.cmi +printf.cmx: string.cmx obj.cmx list.cmx char.cmx buffer.cmx array.cmx \ + printf.cmi queue.cmo: obj.cmi queue.cmi queue.cmx: obj.cmx queue.cmi random.cmo: string.cmi pervasives.cmi nativeint.cmi int64.cmi int32.cmi \ @@ -94,11 +96,13 @@ stdLabels.cmx: stringLabels.cmx listLabels.cmx arrayLabels.cmx stdLabels.cmi stream.cmo: string.cmi obj.cmi list.cmi stream.cmi stream.cmx: string.cmx obj.cmx list.cmx stream.cmi -string.cmo: pervasives.cmi list.cmi char.cmi string.cmi -string.cmx: pervasives.cmx list.cmx char.cmx string.cmi stringLabels.cmo: string.cmi stringLabels.cmi stringLabels.cmx: string.cmx stringLabels.cmi +string.cmo: pervasives.cmi list.cmi char.cmi string.cmi +string.cmx: pervasives.cmx list.cmx char.cmx string.cmi sys.cmo: sys.cmi sys.cmx: sys.cmi +ty.cmo: ty.cmi +ty.cmx: ty.cmi weak.cmo: sys.cmi obj.cmi hashtbl.cmi array.cmi weak.cmi weak.cmx: sys.cmx obj.cmx hashtbl.cmx array.cmx weak.cmi diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/stdlib/Makefile ocaml/stdlib/Makefile --- ocaml.cvs/stdlib/Makefile 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/stdlib/Makefile 2006-03-28 23:25:55.000000000 +0200 @@ -26,11 +26,12 @@ OBJS=pervasives.cmo $(OTHERS) OTHERS=array.cmo list.cmo char.cmo string.cmo sys.cmo \ - hashtbl.cmo sort.cmo marshal.cmo obj.cmo \ int32.cmo int64.cmo nativeint.cmo \ - lexing.cmo parsing.cmo \ + marshal.cmo sort.cmo obj.cmo \ + hashtbl.cmo lexing.cmo parsing.cmo \ set.cmo map.cmo stack.cmo queue.cmo stream.cmo buffer.cmo \ printf.cmo format.cmo scanf.cmo \ + ty.cmo \ arg.cmo printexc.cmo gc.cmo \ digest.cmo random.cmo callback.cmo \ camlinternalOO.cmo oo.cmo camlinternalMod.cmo \ diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/stdlib/StdlibModules ocaml/stdlib/StdlibModules --- ocaml.cvs/stdlib/StdlibModules 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/stdlib/StdlibModules 2006-03-28 23:25:55.000000000 +0200 @@ -45,4 +45,5 @@ string \ stringLabels \ sys \ + ty \ weak diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/stdlib/sys.ml ocaml/stdlib/sys.ml --- ocaml.cvs/stdlib/sys.ml 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/stdlib/sys.ml 2006-10-09 22:12:49.000000000 +0200 @@ -78,4 +78,4 @@ (* OCaml version string, must be in the format described in sys.mli. *) -let ocaml_version = "3.09.3";; +let ocaml_version = "3.09.3+ty2";; diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/stdlib/ty-fra.mli ocaml/stdlib/ty-fra.mli --- ocaml.cvs/stdlib/ty-fra.mli 1970-01-01 01:00:00.000000000 +0100 +++ ocaml/stdlib/ty-fra.mli 2006-05-24 05:11:03.000000000 +0200 @@ -0,0 +1,134 @@ +(* vim:fileencoding=8bit-latin1 *) + +(** Fonctions de déconstruction des valeurs du type ['a tyrepr]. *) + +(** {6 Déclaration de type} *) + +(** Une valeur de ce type est insérée à la compilation d'un module pour chaque + déclaration de type. *) +type declaration +(** Ajouter cette information dans les modules permet lors de l'éxécution + de franchir les barrières d'abstraction du {i type-checker} ... *) + +(** [name decl] retourne le nom du constructeur de type defini par [decl]. *) +val name: declaration -> string + +(** [name decl] retourne le nom du constructeur de type defini par [decl], + ainsi que le nom du fichier et la ligne où il a été déclaré. *) +val fullname: declaration -> string + +(** [arity decl] retourne l'arité du constructeur de type defini par [decl]. *) +val arity: declaration -> int + +(** [is_alias decl] retourne vrai si [decl] correspond à la définition d'un + alias de type. Elle retourne faux si [d] est abstrait dans la signature + et dans la structure du module source. *) +val is_alias: declaration -> bool + +(** [is_datatype decl] retourne vrai si [decl] correspond à la définition d'un + nouveau type somme ou enregistrement. Elle retourne faux si [decl] est + abstrait dans la signature et dans la structure du module source. *) +val is_datatype: declaration -> bool + +(** {6 Expression de type} *) + +(** C'est l'équivalent non-typé du type prédéfini ['a tyrepr]. *) +type expression + +(** La fonction [dump] permet de projeter une expression de type [([^ ty ^] : + ty tyrepr)] vers le type [expression]. *) +val dump: 'a tyrepr -> expression + +(** [body decl] retourne une expression de type correspondant au corps de la + définition de type [decl]. *) +val body: declaration -> expression + +(** [canonical ty] résoud les alias de type pour retourner l'expression + de type équivalente à [ty] et qui correspond à un {i datatype}. *) +val canonical: expression -> expression +(* +C'est à dire que [desc (canonical ty)] est : +- soit un type prédéfini ; +- soit [Tabstract] ; +- soit de la forme [Tconstr(decl,_)] où [is_datatype(decl)] est vrai. +*) + +(** Égalité de type. Elle opère modulo les alias, c'est-à-dire qu'il n'est + pas nécessaire d'appeler [canonical] sur les arguments d'[equal]. *) +val equal: expression -> expression -> bool + +(** Pretty-printing, à faire ... *) +val print: Format.formatter -> expression -> unit + +(** {6 Description d'une expression de type} *) + +(** Description d'une expression de type. *) +type description = + | Tunit + | Tbool + | Tint + | Tnativeint + | Tint32 + | Tint64 + | Tchar + | Tstring + | Tfloat + | Texn + | Tarray of expression + | Tlist of expression + | Toption of expression + | Tlazy of expression + | Ttyrepr of expression + | Tformat4 of expression * expression * expression * expression + | Tconstr of declaration * expression array + | Ttuple of expression array + | Tarrow of string * expression * expression + | Tvariant of bool * (string * int * expression option) array + + | Tabstract + | Tsum of string array * (string * expression array) array + | Tdoublerecord of (string * bool) array + | Trecord of (string * bool * expression) array + | Targ of int + + | Tpoly of int * expression + | Tvar of int + +(** [desc ty] retourne la description de l'expression de type [ty]. + + Cette description correspond aux expressions de type manipulable dans la + syntaxe d'ocaml, et ne contient donc pas de constructeur [Tabstract], + [Tsum], [Tdoublerecord] ou [Trecord]. *) +val desc: expression -> description + +(** [repr ty] retourne la description des représentations mémoire de + l'expression de type [ty]. + + C'est à dire que le terme de tête ne peut pas être [Tconstr], + mais peut-être [Tabstract], [Tsum], [Tdoublerecord] ou [Trecord]. *) +val repr: expression -> description + +(** {6 Safe-unmarshalling} *) + +(** Les fonctions suivantes sont spécifiques pour la dé-sérialisation typée. + Elles opèrent sur des types implicitement quantifiés universellement. + Les constantes [Tvar i] représentent la constante {i Top} de la + formalisation. *) + +(** [cut_head_quantification ty] élimine les éventuels quantificateurs + [Tpoly _] en tête de [ty]. *) +val cut_head_quantification: expression -> expression + +(** Le prédicate [instance ty1 ty2] est vrai si [ty1] est une instance + polymorphe de [ty2]. *) +val instance: expression -> expression -> bool + +(** Anti-unification "sans mémoire". + + La constante [Tvar (-1)] sert à résoudre tout les conflits. *) +val antiunif: expression -> expression -> expression + +(** Le prédicat [monomorphe ty] est vrai lorsque le type [ty] ne contient + pas de variables quantifiées universellement produites par + anti-unification. *) +val is_monomorphic: expression -> bool diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/stdlib/ty.ml ocaml/stdlib/ty.ml --- ocaml.cvs/stdlib/ty.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml/stdlib/ty.ml 2006-10-09 18:21:03.000000000 +0200 @@ -0,0 +1,377 @@ +(* ************** Attention ************** + Tout les changements dans ce module doivent être reporté dans + bytecomp/transltyrepr.ml qui exporte des valeurs de type Ty.declaration et + Ty.expression *) + +(* Helpers, Array *) + +let for_all f a = + let size = Array.length a in + let rec loop i = + i >= size || (f a.(i) && loop (succ i)) in + loop 0 +let for_all2 f a b = + let size = Array.length a in + let rec loop i = + i >= size || (f a.(i) b.(i) && loop (succ i)) in + loop 0 + +let map_option f o = match o with +| None -> None +| Some x -> Some (f x) + +let compare_option f o1 o2 = match (o1,o2) with +| None, None -> true +| Some x1, Some x2 -> f x1 x2 +| _ -> false + +(* End of helpers *) + +type declaration = { + body: expression; + param: int; + name: string; + loc: string * int * int; (* fichier * ligne * caractere *) +} + +and expression = { + mutable desc: description; + mutable repr: description option; + mutable aliases: expression list; +} + +and description = +(* laisser les type predef ainsi ou introduire ici les déclarations + correspondantes ? *) + | Tunit + | Tbool + | Tint + | Tnativeint + | Tint32 + | Tint64 + | Tchar + | Tstring + | Tfloat + | Texn + | Tarray of expression + | Tlist of expression + | Toption of expression + | Tlazy of expression + | Ttyrepr of expression + | Tformat4 of expression * expression * expression * expression + | Tconstr of declaration * expression array + | Ttuple of expression array + | Tarrow of string * expression * expression + | Tvariant of bool * (string * int * expression option) array + + | Tabstract +(* | Tcustom of string ? *) + | Tsum of string array * (string * expression array) array + | Tdoublerecord of (string * bool) array + | Trecord of (string * bool * expression ) array +(* | Tdoublearray ? *) + | Targ of int + + | Tpoly of int * expression + | Tvar of int (* indice de De Bruijn *) + +(* Accesseurs pour le type declaration *) + +let name d = d.name +let fullname d = + let file, line, char = d.loc in + Format.sprintf "%s@%s:%d,%d" d.name file line char +let arity d = d.param +let body d = d.body + +let is_datatype decl = + match decl.body.repr with + | Some (Tsum _) + | Some (Trecord _) + | Some (Tdoublerecord _) -> true + | _ -> false +and is_alias decl = + match decl.body.repr with + | Some Tabstract + | Some (Tsum _) + | Some (Trecord _) + | Some (Tdoublerecord _) -> false + | _ -> true + +(* Expression *) + +let dump (ty: 'a tyrepr) = (Obj.magic ty: expression ) +let create d = { desc = d; repr = None; aliases= []; } +let new_dummy_expr () = create Tabstract + +(** Simple substitution of 'Targ _' in an type expression *) + +let rec subst_expr context env ty = + try List.assq ty context + with Not_found -> + match ty.desc with + | Targ i -> env.(i) + | _ -> + let expr = new_dummy_expr () in + let context = (ty,expr)::context in + expr.desc <- subst_desc context env ty.desc; + expr +and subst_desc context env ty = + match ty with + | Targ i -> assert false + | Tarray ty -> Tarray (subst_expr context env ty) + | Tlist ty -> Tlist (subst_expr context env ty) + | Toption ty -> Toption (subst_expr context env ty) + | Tlazy ty -> Tlazy (subst_expr context env ty) + | Ttyrepr ty -> Ttyrepr (subst_expr context env ty) + | Tconstr (decl,tys) -> + Tconstr (decl, Array.map (subst_expr context env) tys) + | Ttuple tys -> Ttuple (Array.map (subst_expr context env) tys) + | Tarrow (name,ty1,ty2) -> + Tarrow (name, subst_expr context env ty1, subst_expr context env ty2) + | Tvariant (closed,row) -> + Tvariant (closed, + Array.map (fun (s,i,ty) -> + (s,i,map_option (subst_expr context env) ty) ) + row) + | Tsum (const, nconst) -> + Tsum (const, + Array.map + (fun (name,tys) -> (name, + Array.map (subst_expr context env) tys)) + nconst) + | Trecord args -> + Trecord (Array.map + (fun (name, mut, ty) -> + (name, mut, subst_expr context env ty)) + args) + | Tpoly (i, ty) -> Tpoly(i, subst_expr context env ty) + | ty -> ty +let subst = subst_expr [] + +(** Canonical type expresion : resolve aliases for head constructor. *) + +let rec resolve_aliases aliases ty = + let aliases = ty :: aliases in + match ty.desc with + | Tconstr(decl, args) when is_alias decl -> + (* check arity ?? *) + let ty = + match decl.body.repr with + | None -> create Tabstract + | Some desc -> subst args (create desc) + in + resolve_aliases aliases ty + | _ -> aliases + +let canonical ty = + if ty.aliases = [] then + ty.aliases <- resolve_aliases [] ty; + List.hd ty.aliases + +(** Equality *) + +let rec equal_rec context ty1 ty2 = + let ty1 = canonical ty1 + and ty2 = canonical ty2 in + ty1 == ty2 || + List.exists (fun (l,r) -> l == ty1 && r == ty2) context || + (* serait-ce utile aussi de gérer le partage (comme optimisation) ? *) + let context = (ty1, ty2) :: context in + equal_desc_rec context ty1.desc ty2.desc +and equal_desc_rec context ty1 ty2 = + match (ty1, ty2) with + | (Tarray ty1, Tarray ty2) + | (Tlist ty1, Tlist ty2) + | (Toption ty1, Toption ty2) + | (Tlazy ty1, Tlazy ty2) + | (Ttyrepr ty1, Ttyrepr ty2) -> equal_rec context ty1 ty2 + | (Tformat4 (a,b,c,d), Tformat4 (e,f,g,h)) -> + equal_rec context a e && equal_rec context b f && + equal_rec context c g && equal_rec context d h + | (Tconstr (decl1, arg1), Tconstr (decl2, arg2)) -> + ( decl1 == decl2 && for_all2 (equal_rec context) arg1 arg2 ) + | (Ttuple arg1, Ttuple arg2) -> for_all2 (equal_rec context) arg1 arg2 + | (Tarrow (l1,tl1,tr1), Tarrow(l2,tl2,tr2)) -> + (* Dois-t'on gérer la commutation ? *) + l1 = l2 && equal_rec context tl1 tl2 && equal_rec context tr1 tr2 + | (Tsum (const1, nconst1) , Tsum (const2, nconst2)) -> + const1 = const2 && + for_all2 + (fun (n1, tys1) (n2, tys2) -> n1 = n2 && + for_all2 (fun ty1 ty2 -> equal_rec context ty1 ty2) tys1 tys2) + nconst1 nconst2 + | (Tvariant (c1,row1), Tvariant (c2,row2)) -> + c1 == c2 && + for_all2 + (fun (s1,i1,ty1) (s2,i2,ty2) -> + s1 = s2 (* && i1 = i2 *) + && compare_option (equal_rec context) ty1 ty2) + row1 row2 + | (Trecord r1, Trecord r2) -> + for_all2 + (fun (n1, m1, ty1) (n2, m2, ty2) -> n1 = n2 && m1 = m2 && + equal_rec context ty1 ty2) + r1 r2 + | (Tpoly (i1,ty1), Tpoly (i2,ty2)) -> + i1 = i2 && equal_rec context ty1 ty2 + | (ty1, ty2) -> ty1 = ty2 + +let equal ty1 ty2 = equal_rec [] ty1 ty2 + +(* Building type *) +let desc ty = ty.desc +let repr ty = + match ty.repr with + | Some desc -> desc + | None -> + let desc = + match (canonical ty).desc with + | Tconstr (decl, args) -> + begin + match decl.body.repr with + | None -> Tabstract + | Some desc -> subst_desc [ty,ty] args desc + end + | desc -> desc + in + ty.repr <- Some desc; + desc + +let rec cut_head_quantification ty = + match ty.desc with + | Tpoly (_,ty) -> cut_head_quantification ty + | _ -> ty + +(** Instanciation + (dans notre cas spécial où toutes les variables quantifiées + universellement sont confondues) *) + +let rec instance_rec context ty1 ty2 = + let ty1 = canonical ty1 + and ty2 = canonical ty2 in + ty1 == ty2 || + List.exists (fun (l,r) -> l == ty1 && r == ty2) context || + (* serait-ce utile aussi de gérer le partage (comme optimisation) ? *) + let context = (ty1, ty2) :: context in + instance_desc_rec context ty1.desc ty2.desc +and instance_desc_rec context ty1 ty2 = + match (ty1, ty2) with + | (_,Tvar _) -> true + | (Tarray ty1, Tarray ty2) + | (Tlist ty1, Tlist ty2) + | (Toption ty1, Toption ty2) + | (Tlazy ty1, Tlazy ty2) + | (Ttyrepr ty1, Ttyrepr ty2) -> instance_rec context ty1 ty2 + | (Tformat4 (a,b,c,d), Tformat4 (e,f,g,h)) -> + instance_rec context a e && instance_rec context b f && + instance_rec context c g && instance_rec context d h + | (Tconstr (f1, tys1), Tconstr (f2, tys2)) -> + f1 == f2 && for_all2 (instance_rec context) tys1 tys2 + + | (Ttuple tys1, Ttuple tys2) -> for_all2 (instance_rec context) tys1 tys2 + | (Tarrow _, Tarrow _) -> assert false (* TODO *) + | (Tvariant (c1,row1), Tvariant (c2,row2)) -> + if c2 then assert false (* TODO *) + else + not c1 && + for_all2 + (fun (s1,i1,ty1) (s2,i2,ty2) -> + s1 = s2 (* && i1 = i2 *) + && compare_option (instance_rec context) ty1 ty2) + row1 row2 + | (Trecord r1, Trecord r2) -> + for_all2 + (fun (n1, m1, ty1) (n2, m2, ty2) -> n1 = n2 && m1 = m2 && + equal_rec context ty1 ty2) + r1 r2 + | (Tpoly (i1,ty1), Tpoly (i2,ty2)) -> + i1 = i2 && equal_rec context ty1 ty2 + | (ty1, ty2) -> ty1 = ty2 + +let instance ty1 ty2 = + instance_rec [] ty1 ty2 + +let rec is_monomorphic_expr context ty = + let ty = canonical ty in + List.memq ty context || + let context = ty :: context in + is_monomorphic_desc context ty.desc +and is_monomorphic_desc context desc = + match desc with + | Tvar (-1) -> false + | Tarray ty + | Tlist ty + | Toption ty + | Tlazy ty + | Ttyrepr ty -> is_monomorphic_expr context ty + | Tformat4 (a,b,c,d) -> + is_monomorphic_expr context a && is_monomorphic_expr context b && + is_monomorphic_expr context c && is_monomorphic_expr context d + | Ttuple tys + | Tconstr (_,tys) -> + for_all (is_monomorphic_expr context) tys + | Tarrow _ -> assert false (* TODO *) + | Tvariant (closed,row) -> + closed && + for_all (fun (_,_,ty) -> + match ty with + | None -> true + | Some ty -> is_monomorphic_expr context ty) + row + | Tsum _ + | Trecord _ -> assert false + | Tpoly _ -> assert false (* TODO exception *) + | ty -> true + +let is_monomorphic ty = is_monomorphic_expr [] ty + +(* anti-unification *) + +let rec antiunif_rec context ty1 ty2 = + let ty1 = canonical ty1 + and ty2 = canonical ty2 in + let rec search l = + match l with + | (ty1',ty2',ty)::l when ty1' == ty1 && ty2' == ty2 -> ty + | _::l -> search l + | [] -> + let expr = new_dummy_expr () in + let context = (ty1, ty2, expr) :: context in + expr.desc <- + antiunif_desc_rec context ty1.desc ty2.desc; + expr + in + search context +and antiunif_desc_rec context ty1 ty2 = + match (ty1, ty2) with + | (Tarray ty1, Tarray ty2) -> Tarray (antiunif_rec context ty1 ty2) + | (Tlist ty1, Tlist ty2) -> Tlist (antiunif_rec context ty1 ty2) + | (Toption ty1, Toption ty2) -> Toption (antiunif_rec context ty1 ty2) + | (Tlazy ty1, Tlazy ty2) -> Tlazy (antiunif_rec context ty1 ty2) + | (Ttyrepr ty1, Ttyrepr ty2) -> Ttyrepr (antiunif_rec context ty1 ty2) + | (Tformat4 (a,b,c,d), Tformat4 (e,f,g,h)) -> + Tformat4 (antiunif_rec context a e,antiunif_rec context b f, + antiunif_rec context c g,antiunif_rec context d h) + | (Tconstr (decl1, arg1), Tconstr (decl2, arg2)) -> + if decl1 == decl2 then + Tconstr(decl1, + Array.init (Array.length arg1) + (fun i -> antiunif_rec context arg1.(i) arg2.(i))) + else Tvar ~-1 + | (Ttuple arg1, Ttuple arg2) -> + Ttuple(Array.init (Array.length arg1) + (fun i -> antiunif_rec context arg1.(i) arg2.(i))) + | (Tarrow (l1,tl1,tr1), Tarrow(l2,tl2,tr2)) -> assert false (* TODO *) + | (Tvariant _, Tvariant _) -> assert false (* TODO *) + | (Tsum _, _) | (_, Tsum _) + | (Trecord _, _) | (_, Trecord _) + | (Tdoublerecord _,_) | (_,Tdoublerecord _) -> + assert false (* ill-formed canonical *) + | (Tpoly _, Tpoly _) -> assert false (* TODO exception *) + | (ty1, ty2) -> if ty1 = ty2 then ty1 + else Tvar ~-1 + +let antiunif ty1 ty2 = antiunif_rec [] ty1 ty2 + +let print out ty = Format.fprintf out "+TODO+" diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/stdlib/ty.mli ocaml/stdlib/ty.mli --- ocaml.cvs/stdlib/ty.mli 1970-01-01 01:00:00.000000000 +0100 +++ ocaml/stdlib/ty.mli 2006-10-09 18:21:04.000000000 +0200 @@ -0,0 +1,136 @@ +(* + * + * A run-time representation for OCaml types + * + *) + +(** Functions for de-constructing values of type ['a tyrepr]. *) + +(** {6 Type declaration} *) + +(** A value of type [declaration] is produced by the compiler for each + type declaration in a module. This allows at runtime to ``break + the abstraction barriers'' imposed by the type-checker... *) +type declaration + +(** [name decl] returns the name of the type constructor defined by [decl]. *) +val name: declaration -> string + +(** [fullname decl] returns the name of the type constructor defined by [decl], + as well as the line and file name of this decleration. *) +val fullname: declaration -> string + +(** [arity decl] returns the arity of the type constructor defined by [decl]. *) +val arity: declaration -> int + +(** [is_alias decl] returns [true] if [decl] is an alias type declaration. + When [decl] is abstract both on the structure and the signature, it + returns [false]. *) +val is_alias: declaration -> bool + +(** [is_datatype decl] returns [true] if [decl] is a record or sum type + declaration. When [decl] is abstract both on the structure and the + signature, it returns [false]. *) +val is_datatype: declaration -> bool + +(** {6 Type expression} *) + +(** This is the ``untyped'' equivalent of the predefined type ['a tyrepr]. *) +type expression + +(** The [dump] function allows to project a type expression [([^ ty ^] : + ty tyrepr)] to the type [expression]. *) +val dump: 'a tyrepr -> expression + +(** [body decl] returns a type expression describing the body of the + type declaration [decl]. *) +val body: declaration -> expression + +(** [canonical ty] resolves type aliases and returns a type expression + that corresponds to a datatype declaration. + + Therefore, [desc (canonical ty)] + - is a predefined type ; + - or is an abstract type ; + - or has shape [Tconstr(decl,_)] such that [is_datatype(decl)] is true. +*) +val canonical: expression -> expression + +(** Type equality modulo aliases. (It is useless to call [canonical] on + [equal] arguments.) *) +val equal: expression -> expression -> bool + +(** Pretty-printing, FIXME ... *) +val print: Format.formatter -> expression -> unit + +(** {6 Description of type expression } *) + +(** Description of type expressions. *) +type description = + | Tunit + | Tbool + | Tint + | Tnativeint + | Tint32 + | Tint64 + | Tchar + | Tstring + | Tfloat + | Texn + | Tarray of expression + | Tlist of expression + | Toption of expression + | Tlazy of expression + | Ttyrepr of expression + | Tformat4 of expression * expression * expression * expression + | Tconstr of declaration * expression array + | Ttuple of expression array + | Tarrow of string * expression * expression + | Tvariant of bool * (string * int * expression option) array + + | Tabstract + | Tsum of string array * (string * expression array) array + | Tdoublerecord of (string * bool) array + | Trecord of (string * bool * expression) array + | Targ of int + + | Tpoly of int * expression + | Tvar of int + +(** [desc ty] returns a description of the type expression [ty]. + + It corresponds to the type expression that we can write using + OCaml concrete syntax. It therefore excludes constructors such as + [Tabstract], [Tsum], [Tdoublerecord] or [Trecord]. See [repr]. *) +val desc: expression -> description + +(** [repr ty] returns the description of possible memory + representations for the type expression [ty]. + + By contrast with [desc ty], it can be [Tabstract], [Tsum], + [Tdoublerecord] ou [Trecord], but not [Tconstr]. *) +val repr: expression -> description + +(** {6 Safe unmarshalling} *) + +(** The following functions are specific to safe unmarshalling. They + operate on implicitly universally quantified type expression. The + constant [Tvar i] represents the constant {i Top} of the + (currently only in French) formalization. *) + +(** [cut_head_quantification ty] removes hypothetical headings + [Tpoly _] from [ty]. *) +val cut_head_quantification: expression -> expression + +(** [instance ty1 ty2] returns true when [ty1] is a polymorphic + instance [ty2]. *) +val instance: expression -> expression -> bool + +(** Memoryless anti-unification (also sometimes called weak anti-unification). + + We use [Tvar (-1)] for resolving conflicts. *) +val antiunif: expression -> expression -> expression + +(** [is_monomorphic ty] returns [true] when [ty] contains no + occurrence of [Tvar (-1)]. *) +val is_monomorphic: expression -> bool diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/testtyrepr/Makefile ocaml/testtyrepr/Makefile --- ocaml.cvs/testtyrepr/Makefile 1970-01-01 01:00:00.000000000 +0100 +++ ocaml/testtyrepr/Makefile 2006-03-28 23:25:56.000000000 +0200 @@ -0,0 +1,43 @@ +SRC=.. +STDLIB=${SRC}/stdlib +TYSRC=${STDLIB}/ty.ml +OCAMLC=${SRC}/byterun/ocamlrun ${SRC}/ocamlc -nostdlib -I ${STDLIB} +OCAMLOPT=${SRC}/byterun/ocamlrun ${SRC}/ocamlopt -nostdlib -I ${STDLIB} +OCAMLDEP=${SRC}/byterun/ocamlrun ${SRC}/tools/ocamldep + +FILES=test-generator.ml + +all: test +opt: test.opt + +## + +test: tyrepr.byt + ${SRC}/byterun/ocamlrun tyrepr.byt + +test.opt: tyrepr.opt + ./tyrepr.opt + +tyrepr.ml: ${TYSRC} ${FILES} + cat $^ > tyrepr.ml + +tyrepr.byt: tyrepr.cmo + ${OCAMLC} -o tyrepr.byt tyrepr.cmo + +tyrepr.opt: tyrepr.cmx + ${OCAMLOPT} -o tyrepr.opt tyrepr.cmx + +clean:: + rm -f tyrepr.ml tyrepr.byt tyrepr.opt + +## + +%.cmo: %.ml + ${OCAMLC} -c $< +%.cmx: %.ml + ${OCAMLOPT} -c $< +%.cmi: %.mli + ${OCAMLC} -c $< + +clean:: + rm -f *.cm[ioxa] *.o *.a diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/testtyrepr/test-generator.ml ocaml/testtyrepr/test-generator.ml --- ocaml.cvs/testtyrepr/test-generator.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml/testtyrepr/test-generator.ml 2006-03-28 23:25:56.000000000 +0200 @@ -0,0 +1,101 @@ +(** Test des valeurs du type 'a tyrepr et du module Ty. *) + +exception Mismatch of expression * expression +exception Match of expression * expression + +let tmatch (t,t') = if not (equal t t') + then raise (Mismatch(t,t')) + else Format.printf "Success@." +let tmismatch (t,t') = if equal t t' + then raise (Match(t,t')) + else Format.printf "Success@." + +(* Cas de base, tests systématiques *) + +(* let create (d:description) = (Obj.magic (d,None,[]): expression) *) + +let predef = +[ + dump [^ unit ^], create Tunit; + dump [^ int ^], create Tint; + dump [^ nativeint ^], create Tnativeint; + dump [^ int32 ^], create Tint32; + dump [^ int64 ^], create Tint64; + dump [^ char ^], create Tchar; + dump [^ string ^], create Tstring; + dump [^ float ^], create Tfloat; + dump [^ exn ^], create Texn; + + dump [^ unit array ^], create (Tarray (create Tunit)); + dump [^ int array ^], create (Tarray (create Tint)); + dump [^ nativeint list ^], create (Tlist (create Tnativeint)); + dump [^ int32 list ^], create (Tlist (create Tint32)); + dump [^ int64 option ^], create (Toption (create Tint64)); + dump [^ char option ^], create (Toption (create Tchar)); + (* [^ string lazy ^], Tlazy Tstring; + [^ float lazy ^], Tlazy Tfloat; *) + dump [^ exn tyrepr ^], create (Ttyrepr (create Texn)); + dump [^ unit tyrepr ^], create (Ttyrepr (create Tunit)); + dump [^ (unit, int, nativeint, int32) format4 ^], + create (Tformat4 ((create Tunit), (create Tint), + (create Tnativeint), (create Tint32))); + dump [^ (char * string) ^], create (Ttuple [| (create Tchar); + (create Tstring) |]); + dump [^ (unit * int * string * float) ^], + create (Ttuple [| (create Tunit); (create Tint); + (create Tstring); (create Tfloat) |]); + + dump [^ ?f:int -> float -> string ^], + create (Tarrow ("?f", (create Tint), + (create (Tarrow ("", (create Tfloat), (create Tstring)))))); + + (* dump [^ 'a list as 'a ^], create (Tlist e) *) +] + +(* alias de type *) + +type a = int list +type 'a b = 'a * int +type ('a, 'b) c = ('a option * 'b) list + +let alias = [ + dump [^ a ^], create (Tlist (create Tint)); + dump [^ bool b ^], create (Ttuple [|create Tbool; create Tint|]); + dump [^ (int, float) c ^], + create (Tlist (create (Ttuple [| create (Toption (create Tint)); + create Tfloat |]))); + dump [^ (int, float) c ^], dump [^ (int option * float) list ^]; +] + +(* datatypes *) + +type d_a +type 'a d_b = A | B | C of int * float | D of 'a +type ('a, 'b) d_c = { a: 'a; mutable b: 'b } +type d_d = { a : float ; mutable b : float } + +let data = [ + create(repr(dump [^ d_a ^])), create Tabstract; + create(repr(dump [^ int d_b ^])), create (Tsum ([|"A";"B"|], + [|"C", [|create Tint; + create Tfloat |]; + "D", [|create Tint|] |] )); + create(repr(dump [^ (int, float) d_c ^])), create (Trecord [|"a", false, create Tint; + "b", true, create Tfloat; + |]); + create(repr(dump [^ d_d ^])), create (Tdoublerecord [|"a",false; "b",true|]) +] + +let _ = try + Format.printf "--Predef@."; + List.iter tmatch predef; + Format.printf "--Alias@."; + List.iter tmatch alias; + Format.printf "--Datatype@."; + List.iter tmatch data; +with +| Mismatch (t1,t2) -> Format.eprintf "Error: Mismatch %a - %a@." + print t1 + print t2 +| Match (t1,t2) -> Format.eprintf "Error: Match %a@." print t2 + diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/testtyrepr/tyrepr.ml ocaml/testtyrepr/tyrepr.ml --- ocaml.cvs/testtyrepr/tyrepr.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml/testtyrepr/tyrepr.ml 2006-03-28 23:25:56.000000000 +0200 @@ -0,0 +1,439 @@ +(* ************** Attention ************** + Tout les changements dans ce module doivent être reporté dans + bytecomp/transltyrepr.ml qui exporte des valeurs de type Ty.declaration et + Ty.expression *) + +(* Helpers, Array *) + +let for_all f a = + let size = Array.length a in + let rec loop i = + i >= size || (f a.(i) && loop (succ i)) in + loop 0 +let for_all2 f a b = + let size = Array.length a in + let rec loop i = + i >= size || (f a.(i) b.(i) && loop (succ i)) in + loop 0 + +(* End of helpers *) + +type declaration = { + body: expression; + param: int; + name: string; + loc: string * int * int; (* fichier * ligne * caractere *) +} + +and expression = { + mutable desc: description; + mutable repr: description option; + mutable aliases: expression list; +} + +and description = +(* laisser les type predef ainsi ou introduire ici les déclarations + correspondantes ? *) + | Tunit + | Tbool + | Tint + | Tnativeint + | Tint32 + | Tint64 + | Tchar + | Tstring + | Tfloat + | Texn + | Tarray of expression + | Tlist of expression + | Toption of expression + | Tlazy of expression + | Ttyrepr of expression + | Tformat4 of expression * expression * expression * expression + | Tconstr of declaration * expression array + | Ttuple of expression array + | Tarrow of string * expression * expression + + | Tabstract +(* | Tcustom of string ? *) + | Tsum of string array * (string * expression array) array + | Tdoublerecord of (string * bool) array + | Trecord of (string * bool * expression ) array +(* | Tdoublearray ? *) +(* | Tvariant of ? *) + | Targ of int + + | Tpoly of int * expression + | Tvar of int (* indice de De Bruijn *) + +(* Accesseurs pour le type declaration *) + +let name d = d.name +let fullname d = + let file, line, char = d.loc in + Format.sprintf "%s@%s:%d,%d" d.name file line char +let arity d = d.param +let body d = d.body + +let is_datatype decl = + match decl.body.repr with + | Some (Tsum _) + | Some (Trecord _) + | Some (Tdoublerecord _) -> true + | _ -> false +and is_alias decl = + match decl.body.repr with + | Some Tabstract + | Some (Tsum _) + | Some (Trecord _) + | Some (Tdoublerecord _) -> false + | _ -> true + +(* Expression *) + +let dump (ty: 'a tyrepr) = (Obj.magic ty: expression ) +let create d = { desc = d; repr = None; aliases= []; } +let new_dummy_expr () = create Tabstract + +(** Simple substitution of 'Targ _' in an type expression *) + +let rec subst_expr context env ty = + try List.assq ty context + with Not_found -> + match ty.desc with + | Targ i -> env.(i) + | _ -> + let expr = new_dummy_expr () in + let context = (ty,expr)::context in + expr.desc <- subst_desc context env ty.desc; + expr +and subst_desc context env ty = + match ty with + | Targ i -> assert false + | Tarray ty -> Tarray (subst_expr context env ty) + | Tlist ty -> Tlist (subst_expr context env ty) + | Toption ty -> Toption (subst_expr context env ty) + | Tlazy ty -> Tlazy (subst_expr context env ty) + | Ttyrepr ty -> Ttyrepr (subst_expr context env ty) + | Tconstr (decl,tys) -> + Tconstr (decl, Array.map (subst_expr context env) tys) + | Ttuple tys -> Ttuple (Array.map (subst_expr context env) tys) + | Tarrow (name,ty1,ty2) -> + Tarrow (name, subst_expr context env ty1, subst_expr context env ty2) + | Tsum (const, nconst) -> + Tsum (const, + Array.map + (fun (name,tys) -> (name, + Array.map (subst_expr context env) tys)) + nconst) + | Trecord args -> + Trecord (Array.map + (fun (name, mut, ty) -> + (name, mut, subst_expr context env ty)) + args) + | Tpoly (i, ty) -> Tpoly(i, subst_expr context env ty) + | ty -> ty +let subst = subst_expr [] + +(** Canonical type expresion : resolve aliases for head constructor. *) + +let rec resolve_aliases aliases ty = + let aliases = ty :: aliases in + match ty.desc with + | Tconstr(decl, args) when is_alias decl -> + (* check arity ?? *) + let ty = + match decl.body.repr with + | None -> create Tabstract + | Some desc -> subst args (create desc) + in + resolve_aliases aliases ty + | _ -> aliases + +let canonical ty = + if ty.aliases = [] then + ty.aliases <- resolve_aliases [] ty; + List.hd ty.aliases + +(** Equality *) + +let rec equal_rec context ty1 ty2 = + let ty1 = canonical ty1 + and ty2 = canonical ty2 in + ty1 == ty2 || + List.exists (fun (l,r) -> l == ty1 && r == ty2) context || + (* serait-ce utile aussi de gérer le partage (comme optimisation) ? *) + let context = (ty1, ty2) :: context in + equal_desc_rec context ty1.desc ty2.desc +and equal_desc_rec context ty1 ty2 = + match (ty1, ty2) with + | (Tarray ty1, Tarray ty2) + | (Tlist ty1, Tlist ty2) + | (Toption ty1, Toption ty2) + | (Tlazy ty1, Tlazy ty2) + | (Ttyrepr ty1, Ttyrepr ty2) -> equal_rec context ty1 ty2 + | (Tformat4 (a,b,c,d), Tformat4 (e,f,g,h)) -> + equal_rec context a e && equal_rec context b f && + equal_rec context c g && equal_rec context d h + | (Tconstr (decl1, arg1), Tconstr (decl2, arg2)) -> + ( decl1 == decl2 && for_all2 (equal_rec context) arg1 arg2 ) + | (Ttuple arg1, Ttuple arg2) -> for_all2 (equal_rec context) arg1 arg2 + | (Tarrow (l1,tl1,tr1), Tarrow(l2,tl2,tr2)) -> + (* Dois-t'on gérer la commutation ? *) + l1 = l2 && equal_rec context tl1 tl2 && equal_rec context tr1 tr2 + | (Tsum (const1, nconst1) , Tsum (const2, nconst2)) -> + const1 = const2 && + for_all2 + (fun (n1, tys1) (n2, tys2) -> n1 = n2 && + for_all2 (fun ty1 ty2 -> equal_rec context ty1 ty2) tys1 tys2) + nconst1 nconst2 + | (Trecord r1, Trecord r2) -> + for_all2 + (fun (n1, m1, ty1) (n2, m2, ty2) -> n1 = n2 && m1 = m2 && + equal_rec context ty1 ty2) + r1 r2 + | (Tpoly (i1,ty1), Tpoly (i2,ty2)) -> + i1 = i2 && equal_rec context ty1 ty2 + | (ty1, ty2) -> ty1 = ty2 + +let equal ty1 ty2 = equal_rec [] ty1 ty2 + +(* Building type *) +let desc ty = ty.desc +let repr ty = + match ty.repr with + | Some desc -> desc + | None -> + let desc = + match (canonical ty).desc with + | Tconstr (decl, args) -> + begin + match decl.body.repr with + | None -> Tabstract + | Some desc -> subst_desc [ty,ty] args desc + end + | desc -> desc + in + ty.repr <- Some desc; + desc + +let rec cut_head_quantification ty = + match ty.desc with + | Tpoly (_,ty) -> cut_head_quantification ty + | _ -> ty + +(** Instanciation + (dans notre cas spécial où toutes les variables quantifiées + universellement sont confondues) *) + +let rec instance_rec context ty1 ty2 = + let ty1 = canonical ty1 + and ty2 = canonical ty2 in + ty1 == ty2 || + List.exists (fun (l,r) -> l == ty1 && r == ty2) context || + (* serait-ce utile aussi de gérer le partage (comme optimisation) ? *) + let context = (ty1, ty2) :: context in + instance_desc_rec context ty1.desc ty2.desc +and instance_desc_rec context ty1 ty2 = + match (ty1, ty2) with + | (_,Tvar _) -> true + | (Tarray ty1, Tarray ty2) + | (Tlist ty1, Tlist ty2) + | (Toption ty1, Toption ty2) + | (Tlazy ty1, Tlazy ty2) + | (Ttyrepr ty1, Ttyrepr ty2) -> instance_rec context ty1 ty2 + | (Tformat4 (a,b,c,d), Tformat4 (e,f,g,h)) -> + instance_rec context a e && instance_rec context b f && + instance_rec context c g && instance_rec context d h + | (Tconstr (f1, tys1), Tconstr (f2, tys2)) -> + f1 == f2 && for_all2 (instance_rec context) tys1 tys2 + + | (Ttuple tys1, Ttuple tys2) -> for_all2 (instance_rec context) tys1 tys2 + | (Tarrow _, Tarrow _) -> assert false (* TODO *) + | (Tsum _, _) | (_, Tsum _) + | (Trecord _, _) | (_, Trecord _) + | (Tdoublerecord _,_) | (_,Tdoublerecord _) + -> assert false (* ill-formed canonical *) + | (Tpoly _, _) | (_, Tpoly _) -> assert false (* TODO exception ... *) + | (ty1, ty2) -> ty1 = ty2 + +let instance ty1 ty2 = + instance_rec [] ty1 ty2 + +let rec monomorphe_expr context ty = + let ty = canonical ty in + List.memq ty context || + let context = ty :: context in + monomorphe_desc context ty.desc +and monomorphe_desc context desc = + match desc with + | Tvar (-1) -> false + | Tarray ty + | Tlist ty + | Toption ty + | Tlazy ty + | Ttyrepr ty -> monomorphe_expr context ty + | Tformat4 (a,b,c,d) -> + monomorphe_expr context a && monomorphe_expr context b && + monomorphe_expr context c && monomorphe_expr context d + | Ttuple tys + | Tconstr (_,tys) -> + for_all (monomorphe_expr context) tys + | Tarrow _ -> assert false (* TODO *) + | Tsum _ + | Trecord _ -> assert false + | Tpoly _ -> assert false (* TODO exception *) + | ty -> true + +let monomorphe ty = monomorphe_expr [] ty + +(* anti-unification *) + +let rec antiunif_rec context ty1 ty2 = + let ty1 = canonical ty1 + and ty2 = canonical ty2 in + let rec search l = + match l with + | (ty1',ty2',ty)::l when ty1' == ty1 && ty2' == ty2 -> ty + | _::l -> search l + | [] -> + let expr = new_dummy_expr () in + let context = (ty1, ty2, expr) :: context in + expr.desc <- + antiunif_desc_rec context ty1.desc ty2.desc; + expr + in + search context +and antiunif_desc_rec context ty1 ty2 = + match (ty1, ty2) with + | (Tarray ty1, Tarray ty2) -> Tarray (antiunif_rec context ty1 ty2) + | (Tlist ty1, Tlist ty2) -> Tlist (antiunif_rec context ty1 ty2) + | (Toption ty1, Toption ty2) -> Toption (antiunif_rec context ty1 ty2) + | (Tlazy ty1, Tlazy ty2) -> Tlazy (antiunif_rec context ty1 ty2) + | (Ttyrepr ty1, Ttyrepr ty2) -> Ttyrepr (antiunif_rec context ty1 ty2) + | (Tformat4 (a,b,c,d), Tformat4 (e,f,g,h)) -> + Tformat4 (antiunif_rec context a e,antiunif_rec context b f, + antiunif_rec context c g,antiunif_rec context d h) + | (Tconstr (decl1, arg1), Tconstr (decl2, arg2)) -> + if decl1 == decl2 then + Tconstr(decl1, + Array.init (Array.length arg1) + (fun i -> antiunif_rec context arg1.(i) arg2.(i))) + else Tvar ~-1 + | (Ttuple arg1, Ttuple arg2) -> + Ttuple(Array.init (Array.length arg1) + (fun i -> antiunif_rec context arg1.(i) arg2.(i))) + | (Tarrow (l1,tl1,tr1), Tarrow(l2,tl2,tr2)) -> assert false (* TODO *) + | (Tsum _, _) | (_, Tsum _) + | (Trecord _, _) | (_, Trecord _) + | (Tdoublerecord _,_) | (_,Tdoublerecord _) -> + assert false (* ill-formed canonical *) + | (Tpoly _, Tpoly _) -> assert false (* TODO exception *) + | (ty1, ty2) -> if ty1 = ty2 then ty1 + else Tvar ~-1 + +let antiunif ty1 ty2 = antiunif_rec [] ty1 ty2 + + +let print out ty = Format.fprintf out "+TODO+" +(** Test des valeurs du type 'a tyrepr et du module Ty. *) + +exception Mismatch of expression * expression +exception Match of expression * expression + +let tmatch (t,t') = if not (equal t t') + then raise (Mismatch(t,t')) + else Format.printf "Success@." +let tmismatch (t,t') = if equal t t' + then raise (Match(t,t')) + else Format.printf "Success@." + +(* Cas de base, tests systématiques *) + +(* let create (d:description) = (Obj.magic (d,None,[]): expression) *) + +let predef = +[ + dump [^ unit ^], create Tunit; + dump [^ int ^], create Tint; + dump [^ nativeint ^], create Tnativeint; + dump [^ int32 ^], create Tint32; + dump [^ int64 ^], create Tint64; + dump [^ char ^], create Tchar; + dump [^ string ^], create Tstring; + dump [^ float ^], create Tfloat; + dump [^ exn ^], create Texn; + + dump [^ unit array ^], create (Tarray (create Tunit)); + dump [^ int array ^], create (Tarray (create Tint)); + dump [^ nativeint list ^], create (Tlist (create Tnativeint)); + dump [^ int32 list ^], create (Tlist (create Tint32)); + dump [^ int64 option ^], create (Toption (create Tint64)); + dump [^ char option ^], create (Toption (create Tchar)); + (* [^ string lazy ^], Tlazy Tstring; + [^ float lazy ^], Tlazy Tfloat; *) + dump [^ exn tyrepr ^], create (Ttyrepr (create Texn)); + dump [^ unit tyrepr ^], create (Ttyrepr (create Tunit)); + dump [^ (unit, int, nativeint, int32) format4 ^], + create (Tformat4 ((create Tunit), (create Tint), + (create Tnativeint), (create Tint32))); + dump [^ (char * string) ^], create (Ttuple [| (create Tchar); + (create Tstring) |]); + dump [^ (unit * int * string * float) ^], + create (Ttuple [| (create Tunit); (create Tint); + (create Tstring); (create Tfloat) |]); + + dump [^ ?f:int -> float -> string ^], + create (Tarrow ("?f", (create Tint), + (create (Tarrow ("", (create Tfloat), (create Tstring)))))); + + (* dump [^ 'a list as 'a ^], create (Tlist e) *) +] + +(* alias de type *) + +type a = int list +type 'a b = 'a * int +type ('a, 'b) c = ('a option * 'b) list + +let alias = [ + dump [^ a ^], create (Tlist (create Tint)); + dump [^ bool b ^], create (Ttuple [|create Tbool; create Tint|]); + dump [^ (int, float) c ^], + create (Tlist (create (Ttuple [| create (Toption (create Tint)); + create Tfloat |]))); + dump [^ (int, float) c ^], dump [^ (int option * float) list ^]; +] + +(* datatypes *) + +type d_a +type 'a d_b = A | B | C of int * float | D of 'a +type ('a, 'b) d_c = { a: 'a; mutable b: 'b } +type d_d = { a : float ; mutable b : float } + +let data = [ + create(repr(dump [^ d_a ^])), create Tabstract; + create(repr(dump [^ int d_b ^])), create (Tsum ([|"A";"B"|], + [|"C", [|create Tint; + create Tfloat |]; + "D", [|create Tint|] |] )); + create(repr(dump [^ (int, float) d_c ^])), create (Trecord [|"a", false, create Tint; + "b", true, create Tfloat; + |]); + create(repr(dump [^ d_d ^])), create (Tdoublerecord [|"a",false; "b",true|]) +] + +let _ = try + Format.printf "--Predef@."; + List.iter tmatch predef; + Format.printf "--Alias@."; + List.iter tmatch alias; + Format.printf "--Datatype@."; + List.iter tmatch data; +with +| Mismatch (t1,t2) -> Format.eprintf "Error: Mismatch %a - %a@." + print t1 + print t2 +| Match (t1,t2) -> Format.eprintf "Error: Match %a@." print t2 + diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/tools/addlabels.ml ocaml/tools/addlabels.ml --- ocaml.cvs/tools/addlabels.ml 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/tools/addlabels.ml 2006-03-28 23:25:56.000000000 +0200 @@ -276,7 +276,7 @@ | Pexp_override lst -> List.iter lst ~f:(fun (_,e) -> add_labels_rec e) | Pexp_ident _ | Pexp_constant _ | Pexp_construct _ | Pexp_variant _ - | Pexp_new _ | Pexp_assertfalse | Pexp_object _ -> + | Pexp_new _ | Pexp_assertfalse | Pexp_object _ | Pexp_tyrepr _ -> () let rec add_labels_class ~text ~classes ~values ~methods cl = diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/tools/depend.ml ocaml/tools/depend.ml --- ocaml.cvs/tools/depend.ml 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/tools/depend.ml 2006-03-28 23:25:56.000000000 +0200 @@ -156,6 +156,7 @@ | Pexp_poly (e, t) -> add_expr bv e; add_opt add_type bv t | Pexp_object (pat, fieldl) -> add_pattern bv pat; List.iter (add_class_field bv) fieldl + | Pexp_tyrepr (ty) -> add_type bv ty and add_pat_expr_list bv pel = List.iter (fun (p, e) -> add_pattern bv p; add_expr bv e) pel diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/tools/ocamlprof.ml ocaml/tools/ocamlprof.ml --- ocaml.cvs/tools/ocamlprof.ml 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/tools/ocamlprof.ml 2006-05-23 17:48:38.000000000 +0200 @@ -285,6 +285,7 @@ | Pexp_object (_, fieldl) -> List.iter (rewrite_class_field iflag) fieldl + | Pexp_tyrepr _ -> failwith "Pexp_tyrepr : unimplemented" and rewrite_ifbody iflag ghost sifbody = if !instr_if && not ghost then insert_profile rw_exp sifbody diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/typing/ctype.ml ocaml/typing/ctype.ml --- ocaml.cvs/typing/ctype.ml 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/typing/ctype.ml 2006-10-09 18:12:34.000000000 +0200 @@ -3244,7 +3244,8 @@ try let params = List.map (nondep_type_rec env mid) decl.type_params in let decl = - { type_params = params; + { type_loc = decl.type_loc; + type_params = params; type_arity = decl.type_arity; type_kind = begin try diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/typing/env.ml ocaml/typing/env.ml --- ocaml.cvs/typing/env.ml 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/typing/env.ml 2006-03-28 23:25:56.000000000 +0200 @@ -432,9 +432,9 @@ let (pl, final_sub) = prefix_idents root nextpos sub rem in (p::pl, final_sub) | Tsig_type(id, decl, _) :: rem -> - let p = Pdot(root, Ident.name id, nopos) in + let p = Pdot(root, Ident.name id, pos) in let (pl, final_sub) = - prefix_idents root pos (Subst.add_type id p sub) rem in + prefix_idents root (pos+1) (Subst.add_type id p sub) rem in (p::pl, final_sub) | Tsig_exception(id, decl) :: rem -> let p = Pdot(root, Ident.name id, pos) in @@ -486,7 +486,8 @@ | Tsig_type(id, decl, _) -> let decl' = Subst.type_declaration sub decl in c.comp_types <- - Tbl.add (Ident.name id) (decl', nopos) c.comp_types; + Tbl.add (Ident.name id) (decl', !pos) c.comp_types; + incr pos; List.iter (fun (name, descr) -> c.comp_constrs <- Tbl.add name (descr, nopos) c.comp_constrs) @@ -739,6 +740,9 @@ Btype.cleanup_abbrev (); Subst.reset_for_saving (); let sg = Subst.signature (Subst.for_saving Subst.identity) sg in + (* location in type declaration does not feet well with current + camlp4 compilation methods *) + let sg = List.map Types.clean_decl_location sg in let oc = open_out_bin filename in try output_string oc cmi_magic_number; diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/typing/ident.ml ocaml/typing/ident.ml --- ocaml.cvs/typing/ident.ml 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/typing/ident.ml 2006-03-28 23:25:56.000000000 +0200 @@ -38,6 +38,9 @@ incr currentstamp; { i with stamp = !currentstamp } +let rename_tyrepr i = + { i with name = "[:" ^ i.name } + let name i = i.name let stamp i = i.stamp diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/typing/ident.mli ocaml/typing/ident.mli --- ocaml.cvs/typing/ident.mli 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/typing/ident.mli 2006-03-28 23:25:56.000000000 +0200 @@ -20,6 +20,7 @@ val create_persistent: string -> t val create_predef_exn: string -> t val rename: t -> t +val rename_tyrepr: t -> t val name: t -> string val unique_name: t -> string val unique_toplevel_name: t -> string diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/typing/includemod.ml ocaml/typing/includemod.ml --- ocaml.cvs/typing/includemod.ml 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/typing/includemod.ml 2006-10-09 18:12:35.000000000 +0200 @@ -183,10 +183,10 @@ let nextpos = match item with Tsig_value(_,{val_kind = Val_prim _}) - | Tsig_type(_,_,_) | Tsig_modtype(_,_) | Tsig_cltype(_,_,_) -> pos | Tsig_value(_,_) + | Tsig_type(_,_,_) | Tsig_exception(_,_) | Tsig_module(_,_,_) | Tsig_class(_, _,_) -> pos+1 in @@ -251,7 +251,7 @@ end | (Tsig_type(id1, tydecl1, _), Tsig_type(id2, tydecl2, _), pos) :: rem -> type_declarations env subst id1 tydecl1 tydecl2; - signature_components env subst rem + (pos, Tcoerce_none) :: signature_components env subst rem | (Tsig_exception(id1, excdecl1), Tsig_exception(id2, excdecl2), pos) :: rem -> exception_declarations env subst id1 excdecl1 excdecl2; diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/typing/mtype.ml ocaml/typing/mtype.ml --- ocaml.cvs/typing/mtype.ml 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/typing/mtype.ml 2006-03-28 23:25:56.000000000 +0200 @@ -176,7 +176,7 @@ let pos' = match decl.val_kind with Val_prim _ -> pos | _ -> pos + 1 in type_paths_sig env p pos' rem | Tsig_type(id, decl, _) :: rem -> - Pdot(p, Ident.name id, nopos) :: type_paths_sig env p pos rem + Pdot(p, Ident.name id, pos) :: type_paths_sig env p pos rem | Tsig_module(id, mty, _) :: rem -> type_paths env (Pdot(p, Ident.name id, pos)) mty @ type_paths_sig (Env.add_module id mty env) p (pos+1) rem diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/typing/path.ml ocaml/typing/path.ml --- ocaml.cvs/typing/path.ml 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/typing/path.ml 2006-03-28 23:25:56.000000000 +0200 @@ -47,3 +47,8 @@ | Pdot(p, s, pos) -> head p | Papply(p1, p2) -> assert false +let rec rename_tyrepr = function + Pident id -> Pident (Ident.rename_tyrepr id) + | Pdot(p, s, pos) as path -> path + | Papply(p1, p2) -> failwith "Path.rename_tyrepr" + diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/typing/path.mli ocaml/typing/path.mli --- ocaml.cvs/typing/path.mli 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/typing/path.mli 2006-03-28 23:25:56.000000000 +0200 @@ -27,3 +27,5 @@ val name: t -> string val head: t -> Ident.t + +val rename_tyrepr: t -> t diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/typing/predef.ml ocaml/typing/predef.ml --- ocaml.cvs/typing/predef.ml 2006-10-10 12:01:47.000000000 +0200 +++ ocaml/typing/predef.ml 2006-03-28 23:25:56.000000000 +0200 @@ -89,46 +89,53 @@ let build_initial_env add_type add_exception empty_env = let decl_abstr = - {type_params = []; + {type_loc = Location.none; + type_params = []; type_arity = 0; type_kind = Type_abstract; type_manifest = None; type_variance = []} and decl_bool = - {type_params = []; + {type_loc = Location.none; + type_params = []; type_arity = 0; type_kind = Type_variant(["false",[]; "true",[]], Public); type_manifest = None; type_variance = []} and decl_unit = - {type_params = []; + {type_loc = Location.none; + type_params = []; type_arity = 0; type_kind = Type_variant(["()",[]], Public); type_manifest = None; type_variance = []} and decl_exn = - {type_params = []; + {type_loc = Location.none; + type_params = []; type_arity = 0; type_kind = Type_variant([], Public); type_manifest = None; type_variance = []} and decl_array = let tvar = newgenvar() in - {type_params = [tvar]; + {type_loc = Location.none; + type_params = [tvar]; type_arity = 1; type_kind = Type_abstract; type_manifest = None; type_variance = [true, true, true]} and decl_list = let tvar = newgenvar() in - {type_params = [tvar]; + {type_loc = Location.none; + type_params = [tvar]; type_arity = 1; type_kind = Type_variant(["[]", []; "::", [tvar; type_list tvar]], Public); type_manifest = None; type_variance = [true, false, false]} and decl_format4 = - {type_params = [newgenvar(); newgenvar(); newgenvar(); newgenvar()]; + {type_loc = Location.none; + type_params = [newgenvar(); newgenvar(); newgenvar(); newgenvar()]; type_arity = 4; type_kind = Type_abstract; type_manifest = None; @@ -136,21 +143,24 @@ true, true, true; true, true, true]} and decl_option = let tvar = newgenvar() in - {type_params = [tvar]; + {type_loc = Location.none; + type_params = [tvar]; type_arity = 1; type_kind = Type_variant(["None", []; "Some", [tvar]], Public); type_manifest = None; type_variance = [true, false, false]} and decl_lazy_t = let tvar = newgenvar() in - {type_params = [tvar]; + {type_loc = Location.none; + type_params = [tvar]; type_arity = 1; type_kind = Type_abstract; type_manifest = None; type_variance = [true, false, false]} and decl_tyrepr = let tvar = newgenvar() in - {type_params = [tvar]; + {type_loc = Location.none; + type_params = [tvar]; type_arity = 1; type_kind = Type_abstract; type_manifest = None; diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/typing/subst.ml ocaml/typing/subst.ml --- ocaml.cvs/typing/subst.ml 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/typing/subst.ml 2006-03-28 23:25:56.000000000 +0200 @@ -149,7 +149,8 @@ let type_declaration s decl = let decl = - { type_params = List.map (typexp s) decl.type_params; + { type_loc = decl.type_loc; + type_params = List.map (typexp s) decl.type_params; type_arity = decl.type_arity; type_kind = begin match decl.type_kind with diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/typing/typeclass.ml ocaml/typing/typeclass.ml --- ocaml.cvs/typing/typeclass.ml 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/typing/typeclass.ml 2006-03-28 23:25:56.000000000 +0200 @@ -959,7 +959,8 @@ let ty = Ctype.newobj (Ctype.newvar ()) in let env = Env.add_type id - {type_params = !params; + {type_loc = Location.none; + type_params = !params; type_arity = arity; type_kind = Type_abstract; type_manifest = Some ty; @@ -1164,7 +1165,8 @@ | Concrete -> Some (Ctype.instance constr_type)} in let obj_abbr = - {type_params = obj_params; + {type_loc = snd cl.pci_params; + type_params = obj_params; type_arity = List.length obj_params; type_kind = Type_abstract; type_manifest = Some obj_ty; @@ -1176,7 +1178,8 @@ Ctype.hide_private_methods cl_ty; Ctype.set_object_name obj_id (Ctype.row_variable cl_ty) cl_params cl_ty; let cl_abbr = - {type_params = cl_params; + {type_loc = snd cl.pci_params; + type_params = cl_params; type_arity = List.length cl_params; type_kind = Type_abstract; type_manifest = Some cl_ty; diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/typing/typecore.ml ocaml/typing/typecore.ml --- ocaml.cvs/typing/typecore.ml 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/typing/typecore.ml 2006-05-23 17:48:38.000000000 +0200 @@ -59,6 +59,7 @@ | Not_a_variant_type of Longident.t | Incoherent_label_order | Less_general of string * (type_expr * type_expr) list + | Unbound_type_variable of type_expr exception Error of Location.t * error @@ -618,6 +619,7 @@ Vars.fold (fun _ (mut,_) b -> decr count; b && mut = Immutable) vars true && !count = 0 + | Texp_tyrepr _ -> true | _ -> false and is_nonexpansive_opt = function @@ -1428,7 +1430,23 @@ } | Pexp_poly _ -> assert false - + | Pexp_tyrepr (sty) -> + let ty = Typetexp.transl_type_scheme env sty in +(* if free_variables ty <> [] then + raise(Error(sexp.pexp_loc,Unbound_type_variable ty)); *) + let ty = + match repr ty with + | {desc = Tpoly (ty, [])} -> + instance ty + | _ -> ty + in + re { + exp_desc = Texp_tyrepr ty; + exp_loc = sexp.pexp_loc; + exp_type = instance (Predef.type_tyrepr ty); (* instance_poly ? *) + exp_env = env; + } + and type_argument env sarg ty_expected' = (* ty_expected' may be generic *) let no_labels ty = @@ -2123,3 +2141,5 @@ report_unification_error ppf trace (fun ppf -> fprintf ppf "This %s has type" kind) (fun ppf -> fprintf ppf "which is less general than") + | Unbound_type_variable ty -> + fprintf ppf "Unbound type variable in [^ %a ^]." type_scheme ty diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/typing/typecore.mli ocaml/typing/typecore.mli --- ocaml.cvs/typing/typecore.mli 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/typing/typecore.mli 2006-03-28 23:25:56.000000000 +0200 @@ -96,6 +96,7 @@ | Not_a_variant_type of Longident.t | Incoherent_label_order | Less_general of string * (type_expr * type_expr) list + | Unbound_type_variable of type_expr exception Error of Location.t * error diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/typing/typedecl.ml ocaml/typing/typedecl.ml --- ocaml.cvs/typing/typedecl.ml 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/typing/typedecl.ml 2006-03-28 23:25:56.000000000 +0200 @@ -48,7 +48,8 @@ let enter_type env (name, sdecl) id = let decl = - { type_params = + { type_loc = sdecl.ptype_loc; + type_params = List.map (fun _ -> Btype.newgenvar ()) sdecl.ptype_params; type_arity = List.length sdecl.ptype_params; type_kind = Type_abstract; @@ -124,7 +125,8 @@ sdecl.ptype_cstrs in let decl = - { type_params = params; + { type_loc = sdecl.ptype_loc; + type_params = params; type_arity = List.length params; type_kind = begin match sdecl.ptype_kind with @@ -714,7 +716,8 @@ sdecl.ptype_cstrs; let no_row = sdecl.ptype_kind <> Ptype_private in let decl = - { type_params = params; + { type_loc = sdecl.ptype_loc; + type_params = params; type_arity = List.length params; type_kind = Type_abstract; type_manifest = @@ -747,7 +750,8 @@ if n <= 0 then [] else Ctype.newvar() :: make_params (n-1) in Ctype.begin_def(); let decl = - { type_params = make_params arity; + { type_loc = Location.none; + type_params = make_params arity; type_arity = arity; type_kind = Type_abstract; type_manifest = None; diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/typing/typedtree.ml ocaml/typing/typedtree.ml --- ocaml.cvs/typing/typedtree.ml 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/typing/typedtree.ml 2006-03-28 23:25:56.000000000 +0200 @@ -78,6 +78,7 @@ | Texp_assertfalse | Texp_lazy of expression | Texp_object of class_structure * class_signature * string list + | Texp_tyrepr of type_expr and meth = Tmeth_name of string @@ -210,6 +211,9 @@ let let_bound_idents pat_expr_list = List.rev(rev_let_bound_idents pat_expr_list) +let tyrepr_bound_idents decls = + List.map (fun (id,_) -> Ident.rename_tyrepr id) decls + let alpha_var env id = List.assoc id env let rec alpha_pat env p = match p.pat_desc with diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/typing/typedtree.mli ocaml/typing/typedtree.mli --- ocaml.cvs/typing/typedtree.mli 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/typing/typedtree.mli 2006-03-28 23:25:56.000000000 +0200 @@ -77,6 +77,7 @@ | Texp_assertfalse | Texp_lazy of expression | Texp_object of class_structure * class_signature * string list + | Texp_tyrepr of type_expr and meth = Tmeth_name of string @@ -158,6 +159,7 @@ val let_bound_idents: (pattern * expression) list -> Ident.t list val rev_let_bound_idents: (pattern * expression) list -> Ident.t list +val tyrepr_bound_idents: (Ident.t * type_declaration) list -> Ident.t list (* Alpha conversion of patterns *) val alpha_pat : (Ident.t * Ident.t) list -> pattern -> pattern diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/typing/typemod.ml ocaml/typing/typemod.ml --- ocaml.cvs/typing/typemod.ml 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/typing/typemod.ml 2006-05-23 17:48:38.000000000 +0200 @@ -14,6 +14,7 @@ (* Type-checking of the module language *) +open Asttypes open Misc open Longident open Path @@ -89,7 +90,8 @@ Pwith_type ({ptype_kind = Ptype_private} as sdecl)) when Ident.name id = s -> let decl_row = - { type_params = + { type_loc = loc; + type_params = List.map (fun _ -> Btype.newgenvar()) sdecl.ptype_params; type_arity = List.length sdecl.ptype_params; type_kind = Type_abstract; @@ -464,6 +466,8 @@ | Tsig_exception(id, decl) :: rem -> id :: bound_value_identifiers rem | Tsig_module(id, mty, _) :: rem -> id :: bound_value_identifiers rem | Tsig_class(id, decl, _) :: rem -> id :: bound_value_identifiers rem + | Tsig_type(id, decl, _) :: rem -> + Ident.rename_tyrepr id :: bound_value_identifiers rem | _ :: rem -> bound_value_identifiers rem (* Helpers for typing recursive modules *) diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/typing/types.ml ocaml/typing/types.ml --- ocaml.cvs/typing/types.ml 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/typing/types.ml 2006-03-28 23:25:56.000000000 +0200 @@ -131,7 +131,8 @@ (* Type definitions *) type type_declaration = - { type_params: type_expr list; + { type_loc: Location.t; + type_params: type_expr list; type_arity: int; type_kind: type_kind; type_manifest: type_expr option; @@ -199,3 +200,9 @@ Trec_not | Trec_first | Trec_next + +let clean_decl_location sg = + match sg with + | Tsig_type (id, type_decl, rec_status) -> + Tsig_type (id, { type_decl with type_loc = Location.none} , rec_status) + | sg -> sg diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/typing/types.mli ocaml/typing/types.mli --- ocaml.cvs/typing/types.mli 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/typing/types.mli 2006-03-28 23:25:56.000000000 +0200 @@ -132,7 +132,8 @@ (* Type definitions *) type type_declaration = - { type_params: type_expr list; + { type_loc: Location.t; + type_params: type_expr list; type_arity: int; type_kind: type_kind; type_manifest: type_expr option; @@ -201,3 +202,6 @@ Trec_not (* not recursive *) | Trec_first (* first in a recursive group *) | Trec_next (* not first in a recursive group *) + + +val clean_decl_location: signature_item -> signature_item diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/typing/unused_var.ml ocaml/typing/unused_var.ml --- ocaml.cvs/typing/unused_var.ml 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/typing/unused_var.ml 2006-03-28 23:25:56.000000000 +0200 @@ -172,6 +172,7 @@ | Pexp_lazy e -> expression ppf tbl e; | Pexp_poly (e, _) -> expression ppf tbl e; | Pexp_object cs -> class_structure ppf tbl cs; + | Pexp_tyrepr _ -> () and expression_option ppf tbl eo = match eo with diff -Nur --exclude testlabl --exclude testasmcomp --exclude test --exclude test_stdlib --exclude config --exclude camlheader --exclude .cvsignore --exclude CVS --exclude Saved --exclude _darcs --exclude '*~' --exclude '.#*' --exclude version.sh --exclude version.h --exclude config.ml ocaml.cvs/utils/config.mlp ocaml/utils/config.mlp --- ocaml.cvs/utils/config.mlp 2006-10-10 12:01:45.000000000 +0200 +++ ocaml/utils/config.mlp 2006-03-28 23:25:56.000000000 +0200 @@ -40,13 +40,13 @@ let cc_profile = "%%CC_PROFILE%%" let exec_magic_number = "Caml1999X008" -and cmi_magic_number = "Caml1999I010" -and cmo_magic_number = "Caml1999O006" -and cma_magic_number = "Caml1999A007" -and cmx_magic_number = "Caml1999Y010" -and cmxa_magic_number = "Caml1999Z010" -and ast_impl_magic_number = "Caml1999M010" -and ast_intf_magic_number = "Caml1999N009" +and cmi_magic_number = "Caml1999I011" +and cmo_magic_number = "Caml1999O007" +and cma_magic_number = "Caml1999A008" +and cmx_magic_number = "Caml1999Y011" +and cmxa_magic_number = "Caml1999Z011" +and ast_impl_magic_number = "Caml1999M011" +and ast_intf_magic_number = "Caml1999N010" let load_path = ref ([] : string list)