[r2005-10-30 14:23:02 by afrisch] Moving to OCaml 3.09

Original author: afrisch
Date: 2005-10-30 14:23:04+00:00

CHANGES

+0.4.0
+
+- Adapted to OCaml 3.09.
+- To build the OCaml/CDuce interface, OCaml sources are now needed.
+
 0.3.92
 
 - Tools:

INSTALL

@@ -26,7 +26,7 @@ Mandatory packages:
 Before compiling CDuce, you need to install recent releases of the
 following packages:
 
-ocaml      >= 3.08.3
+ocaml      >= 3.09
   http://caml.inria.fr/ocaml/distrib.html
 findlib    >= 1.0.3 
   http://www.ocaml-programming.de/packages
@@ -150,39 +150,11 @@ You need a GNU Make (or equivalent). The Makefile defines the following goals:
 Building the CDuce/OCaml interface
 ------------------------------------------------------------------------------
 
-If you want to build the OCaml/CDuce interface, you will need some
-parts of the OCaml compilers which are not installed by default with
-OCaml. The files you need are the compiled units from the
-subdirectories utils/ parsing/ and typing/ of the OCaml standard
-distribution (the .cmi files, and either the corresponding .cmo or the
-.cmx+.o). If you still have the compiled OCaml source tree that you used
-to build the current version of ocamlc/ocamlopt, in, say
-$HOME/ocaml-3.07, you can activate the OCaml/CDuce interface with:
-
- ./configure --mliface=$HOME/ocaml-3.08
-
-Another option is to copy all the needed files (.cmi,.cmo/.cmx+.o)
-to a single directory, say $HOME/ocaml-modules. Then you can do:
-
- ./configure --mliface=$HOME/ocaml-modules
-
-(the configure script automatically detect whether the files
-are directly in the specified directory, or in utils/ parsing/ typing/
-subdirectories)
-
-Note for GODI users: 
-====================
-
-The GODI distribution provides the required files by default.
-The configure script will detect them automatically.
-
-
-Note for Debian users:
-======================
-
-The Debian package ocaml-compiler-libs provides the required files.
-The configure script will detect them automatically.
+If you want to build the OCaml/CDuce interface, you need a copy
+of the OCaml source tree matching your current OCaml version.
+You must pass the location of this tree to the configure script:
 
+ ./configure --mliface=$HOME/ocaml-3.09
 
 ------------------------------------------------------------------------------
 Note on XML parsers

Makefile.distrib

@@ -47,7 +47,7 @@ else
   CAMLOPT_P = ocamlopt -inline 10000
 endif
 
-OPT = -warn-error FPS
+OPT = -warn-error FPSXY
 ANNOT =
 INTERFACE =
 ifeq ($(ANNOT), true)
@@ -283,7 +283,7 @@ misc/q_symbol.cmo: misc/q_symbol.ml
 
 .ml.cmx:
 	@echo "Build $@"
-	$(HIDE)$(CAMLOPT) -c $(SYNTAX_PARSER) $(INCLUDES) $<
+	$(HIDE)$(CAMLOPT) -passopt -for-pack -passopt Cduce_lib -c $(SYNTAX_PARSER) $(INCLUDES) $<
 
 .mli.cmi:
 	@echo "Build $@"
@@ -317,10 +317,9 @@ install_doc: doc
 
 ocamliface/caml_cduce.cmo:
 	@cd ocamliface; \
-	$(MAKE) PREFIX=$(ML_MODULES) MODEL=$(ML_INTERFACE) \
-	        HIDE=$(HIDE) caml_cduce.cmo
+	$(MAKE) OCAML_SRC=$(OCAML_SRC) HIDE=$(HIDE) caml_cduce.cmo
 
 ocamliface/caml_cduce.cmx:
 	@cd ocamliface; \
-	$(MAKE) PREFIX=$(ML_MODULES) MODEL=$(ML_INTERFACE) \
-		HIDE=$(HIDE) caml_cduce.cmx
+	$(MAKE) OCAML_SRC=$(OCAML_SRC) HIDE=$(HIDE) caml_cduce.cmx
+

configure.ml

@@ -167,16 +167,7 @@ let exe = match Sys.os_type with
   | _ -> ""
 
 let check_mliface dir =
-  log ("Looking for ocaml modules in " ^ dir);
-  let file = if native then "types.cmx" else "types.cmo" in
-  if Sys.file_exists (Filename.concat dir file) 
-  then `flat
-  else
-    if Sys.file_exists 
-      (Filename.concat (Filename.concat dir "typing") file) then
-	`tree
-    else
-      `not_found
+  Sys.file_exists (Filename.concat dir "typing/types.ml") 
 
 let ocaml_stdlib () =
   if (Sys.command "ocamlc -where > ocaml_stdlib" <> 0) then
@@ -189,26 +180,19 @@ let ocaml_stdlib () =
 
 let ml_interface = 
   let dir1 = !(List.assoc "mliface" vars) in
-  let dirs = 
-    let std = ocaml_stdlib () in
-    Filename.concat (Filename.chop_suffix std "std-lib") "compiler-lib" :: 
-          (* GODI *)
-    Filename.concat std "compiler-libs" :: (* Debian *)
-    src_dirs in
+  let dirs = [] in
   let dirs = if dir1 = "" then dirs else dir1 :: dirs in
-  print "Looking for ocaml compiler modules ...";
+  print "ocaml sources... ";
   let rec loop = function
     | [] -> 
-	print "not found\n";
-	`no
+	print "not found (the interface will not be built)\n";
+	None
     | d::dirs ->
-	match check_mliface d with
-	  | `flat -> print ("flat model: " ^ d ^ "\n"); `flat d
-	  | `tree -> print ("tree model: " ^ d ^ "\n"); `tree d
-	  | `not_found -> loop dirs
+	if check_mliface d then
+	  (print ("found: " ^ d ^ "\n"); Some d)
+	else loop dirs
   in
   loop dirs
-
   
 let pxp = check_feature "pxp" (check_pkg "pxp")
 let expat = check_feature "expat" (check_pkg "expat")
@@ -260,9 +244,8 @@ let () =
   fprintf out "# This file has been generated by the configure script\n";
   fprintf out "NATIVE=%b\n" native;
   (match ml_interface with
-    | `no -> fprintf out "ML_INTERFACE=false\n"
-    | `flat d -> fprintf out "ML_INTERFACE=flat\nML_MODULES=%s\n" d
-    | `tree d -> fprintf out "ML_INTERFACE=tree\nML_MODULES=%s\n" d);
+    | Some d -> fprintf out "ML_INTERFACE=true\nOCAML_SRC=%s\n" d
+    | None -> fprintf out "ML_INTERFACE=false\n");
   fprintf out "PXP=%b\n" pxp;
   fprintf out "EXPAT=%b\n" expat;
   fprintf out "CURL=%b\n" curl;

driver/librarian.ml

@@ -249,7 +249,6 @@ let prepare_stub src =
 
 let ocaml_stub stub =
   let pools, types, (c : t) = Marshal.from_string stub 0 in
-  let i1,i2 = Compunit.get_hash c.descr in
   if Tbl.mem tbl c.name then
     failwith ("CDuce unit " ^ (U.get_str c.name) ^ " already loaded");
   Value.intract_all pools;

misc/encodings.ml

@@ -118,10 +118,10 @@ struct
 
   let advance s i =
     match s.[i] with
-      | '\000'..'\127' as c -> i + 1
-      | '\192'..'\223' as c -> i + 2
-      | '\224'..'\239' as c -> i + 3 
-      | '\240'..'\247' as c -> i + 4
+      | '\000'..'\127' -> i + 1
+      | '\192'..'\223' -> i + 2
+      | '\224'..'\239' -> i + 3 
+      | '\240'..'\247' -> i + 4
       | _ -> failwith "Malformed UTF-8 bufffer"
 (*
   let width = Array.create 256 1

ocamliface/Makefile

 # This Makefile generates caml_cduce.cmo/.cmx
-# 
-# We need the units such that typing/types.cmo  (.cmx)
-#
-# - If OCaml has been compiled in a directory DIR,
-#   you can do:
-#     make MODEL=tree PREFIX=DIR
-#   e.g.: make caml_cduce.cmo MODEL=tree PREFIX=$HOME/ocaml-3.07
-#
-# - If you have a (flat) directory DIR will all the compiled units 
-#   from utils/ parsing/ and typing/, you can do:
-#     make MODEL=flat PREFIX=DIR
-#   e.g.: make caml_cduce.cmo MODEL=flat PREFIX=$HOME/godi/lib/ocaml/compiler-lib
+# It must be called with an OCAML_SRC argument pointing to the root
+# of an OCaml source tree.
 
 
-OCAML_OBJECTS=$(patsubst %,$(PREFIX)/%, $(UNITS))
+all: caml_cduce.cmo caml_cduce.cmx
 
-OBJECTS=$(OCAML_OBJECTS)
-XOBJECTS=$(OBJECTS:.cmo=.cmx)
+STDLIB=$(shell ocamlc -where)
 
-ifeq ($(MODEL),flat)
-  UNITS= $(subst utils/,,$(UTILS)) \
-         $(subst parsing/,,$(PARSING)) \
-         $(subst typing/,,$(TYPING))
-  INCLUDES = -I $(PREFIX)
-  ASTTYPES = $(PREFIX)/asttypes.cmi
-else
-ifeq ($(MODEL),tree)
-  UNITS= $(UTILS) $(PARSING) $(TYPING)
-  INCLUDES = -I $(PREFIX)/utils -I $(PREFIX)/parsing -I $(PREFIX)/typing
-  ASTTYPES = $(PREFIX)/parsing/asttypes.cmi
-else
- $(error Set MODEL=flat or MODEL=tree)
-endif
-endif
+ocaml_files:
+	mkdir ocaml_files
+	$(HIDE)cp $(patsubst %,$(OCAML_SRC)/%, $(COPY_FILES)) ocaml_files/
+	cp location.ml ocaml_files
+	mv ocaml_files/asttypes.mli ocaml_files/asttypes.ml
+	sed s=STDLIB=$(STDLIB)= config.ml > ocaml_files/config.ml
 
-caml_cduce.cmo:
+caml_cduce.cmo: ocaml_files
 	@echo "Build $@"
-	$(HIDE)ocamlc -pack -o $@ $(INCLUDES) $(OBJECTS)
+	(cd ocaml_files; ocamlc -for-pack Cduce_lib.Caml_cduce $@ -c $(COMPILE_FILES);\
+	ocamlc -for-pack Cduce_lib -pack -o $@ $(OBJECTS); \
+	cp caml_cduce.cmo caml_cduce.cmi ..)
 
-caml_cduce.cmx:
+caml_cduce.cmx: ocaml_files
 	@echo "Build $@"
-	$(HIDE)ocamlopt -pack -o $@ $(INCLUDES) $(XOBJECTS)
-
-## Hack to rebuild asttypes.ml from asttypes.cmi
-## (because -pack needs .cmo in 3.07)
-
-.PHONY: asttypes.ml
-asttypes.ml: cmi2ml
-	@echo "Create $@"
-	$(HIDE)./cmi2ml Asttypes $(ASTTYPES) > asttypes.ml
-
-asttypes.mli: asttypes.ml
-	cp asttypes.ml asttypes.mli
-
-cmi2ml: cmi2ml.ml
-	@echo "Build $@"
-	$(HIDE)ocamlc -o $@ $(INCLUDES) $(OCAML_OBJECTS) $<
-
-
-UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \
-  utils/clflags.cmo utils/consistbl.cmo utils/warnings.cmo utils/terminfo.cmo
-
-PARSING=parsing/linenum.cmo parsing/location.cmo parsing/longident.cmo parsing/asttypes.cmi
-
-TYPING=typing/ident.cmo typing/path.cmo \
-  typing/primitive.cmo typing/types.cmo \
-  typing/btype.cmo typing/oprint.cmo \
-  typing/subst.cmo typing/predef.cmo \
-  typing/datarepr.cmo typing/env.cmo \
-  typing/ctype.cmo typing/printtyp.cmo
-
+	(cd ocaml_files; ocamlopt -for-pack Cduce_lib.Caml_cduce $@ -c $(COMPILE_FILES);\
+	ocamlopt -for-pack Cduce_lib -pack -o $@ $(XOBJECTS); \
+	cp caml_cduce.cmx caml_cduce.o caml_cduce.cmi ..)
+
+clean:
+	rm -Rf ocaml_files *~ *.cm*
+
+COPY_FILES=\
+  utils/misc.ml utils/tbl.ml \
+  utils/consistbl.ml utils/warnings.ml utils/terminfo.ml utils/clflags.ml \
+  parsing/asttypes.mli parsing/longident.ml \
+  typing/ident.ml typing/path.ml \
+  typing/primitive.ml typing/types.ml \
+  typing/btype.ml typing/oprint.ml \
+  typing/subst.ml typing/predef.ml \
+  typing/datarepr.ml typing/env.ml \
+  typing/ctype.ml typing/ctype.mli typing/printtyp.ml
+
+COMPILE_FILES=\
+  config.ml misc.ml tbl.ml \
+  clflags.ml consistbl.ml warnings.ml terminfo.ml \
+  location.ml asttypes.ml longident.ml \
+  ident.ml path.ml \
+  primitive.ml types.ml \
+  btype.ml oprint.ml \
+  subst.ml predef.ml \
+  datarepr.ml env.ml ctype.mli ctype.ml printtyp.ml
+
+COMPILE_FILES_ML=$(filter %.ml,$(COMPILE_FILES))
+OBJECTS=$(COMPILE_FILES_ML:.ml=.cmo)
+XOBJECTS=$(COMPILE_FILES_ML:.ml=.cmx)
\ No newline at end of file

ocamliface/cdo2ml.ml

-(*
-let list_lit el =
-  List.fold_right (fun a e -> <:expr< [$a$ :: $e$] >>) el <:expr< [] >>
-*)
-
-let () =
-  let str_items = Marshal.from_channel stdin in
-  !Pcaml.print_implem str_items

ocamliface/cmi2ml.ml

-let () =
-  let sg = Env.read_signature Sys.argv.(1) Sys.argv.(2) in
-  Printtyp.signature Format.std_formatter sg

ocamliface/config.ml

+let standard_library = "STDLIB"
+let load_path = ref ([] : string list)
+let cmi_magic_number = "Caml1999I010"
+let bytecomp_c_compiler = ""
+let bytecomp_c_linker = ""

ocamliface/location.ml

+open Lexing
+type t = { loc_start: position; loc_end: position; loc_ghost: bool }

ocamliface/mlcduce_wrapper.ml

-let loc = (Lexing.dummy_pos, Lexing.dummy_pos)
-
-let usage =
-"Usage: mlcduce_wrapper [-I path ...] <primitive file>
-" 
-
-let err s = prerr_endline s; prerr_endline usage; exit 1
-
-
-let rec args = function
-  | "-I"::path::rest ->
-      Librarian.obj_path := path::!Librarian.obj_path;
-      args rest
-  | [p] -> p
-  | _ -> err "Invalid command line"
-
-
-let () =
-  let fn = args (List.tl (Array.to_list Sys.argv)) in
-  let ic = 
-    try open_in fn
-    with Sys_error s -> err s in
-  let v = ref [] in
-  (try while true do 
-     let s = input_line ic in
-     if s <> "" then
-       match s.[0] with
-	 | 'A'..'Z' -> v := s :: !v 
-	 | '#' -> ()
-	 | _ -> err "Names must start with a capitalized letter"
-   done 
-   with End_of_file -> ());
-  let s = Mlstub.gen_wrapper !v in
-  !Pcaml.print_implem [ s,loc ];
-  print_endline "let () = Librarian.obj_path := [";
-  List.iter (fun s -> Printf.printf "  %S;\n" s) !Librarian.obj_path;
-  print_endline " ];;";
-  print_endline "let () = Run.main ();;"
-

ocamliface/mlstub.ml

@@ -77,7 +77,7 @@ let mk_var _ =
 
 let mk_vars = List.map mk_var
 
-let loc = (Lexing.dummy_pos,Lexing.dummy_pos)
+let _loc = (Lexing.dummy_pos,Lexing.dummy_pos)
 
 let let_in p e body =
   <:expr< let $list:[ p, e ]$ in $body$ >>
@@ -348,7 +348,6 @@ and to_ml_descr e = function
 	 | "B",Some x -> `B (t(x))
 	 | _ -> assert false
       *)
-      let x = mk_var () in
       let cases = 
 	List.map 
 	  (function 
@@ -637,7 +636,7 @@ let make_wrapper fn =
    done 
    with End_of_file -> ());
   let s = gen_wrapper !v in
-  !Pcaml.print_implem [ s,loc ];
+  !Pcaml.print_implem [ s,_loc ];
   print_endline "let () = Librarian.obj_path := [";
   List.iter (fun s -> Printf.printf "  %S;\n" s) !Librarian.obj_path;
   print_endline " ];;";

ocamliface/mltypes.ml

@@ -2,8 +2,7 @@ exception Error of string
 
 module Loc = Location
 open Caml_cduce
-open Asttypes
-open Types
+open Caml_cduce.Types
 
 (* Unfolding of OCaml types *)
 
@@ -168,10 +167,10 @@ let rec unfold_constr env p args =
 	       let cstrs =
 		 List.map 
 		   (fun (cst,f) -> (cst,List.map (unfold env) f)) cstrs in
-	       Variant (prefix, cstrs, pub = Public)
+	       Variant (prefix, cstrs, pub = Caml_cduce.Asttypes.Public)
 	   | Type_record (f,_,pub), _ ->
 	       let f = List.map (fun (l,_,t) -> (l,unfold env t)) f in
-	       Record (prefix, f, pub = Public)
+	       Record (prefix, f, pub = Caml_cduce.Asttypes.Public)
 	   | Type_abstract, Some t ->
 	       Link (unfold env t)
 	   | Type_abstract, None ->

runtime/cduce_expat.ml

@@ -30,8 +30,6 @@ let rec push p s =
     if Url.is_url s then Expat.parse p (Url.load_url s)
     else load_from_file p s
   with Expat.Expat_error e -> 
-    let line = Expat.get_current_line_number p 
-    and col  = Expat.get_current_column_number p in
     let msg =
       Printf.sprintf
 	"load_xml,%s at line %i, column %i: %s"

schema/schema_common.ml

@@ -33,8 +33,7 @@ let merge_facets old_facets new_facets =
     | Some _, Some _ -> assert false
     | v -> v
   in
-  { old_facets with
-      length =
+  {   length =
         (match new_facets.length with
         | None -> old_facets.length
         | v -> v);

schema/schema_validator.ml

@@ -414,7 +414,6 @@ and validate_content_type ctx content_type =
   | CT_simple st_def -> 
       validate_simple_type st_def (get_string ctx)
   | CT_model (particle, mixed) ->
-      let mixold = ctx.ctx_mixed in
       let ctx = subctx mixed ctx in
       validate_particle ctx particle;
       get ctx
@@ -431,15 +430,14 @@ and validate_particle ctx particle =
 	cont_failure ev
   in
   let rec required = function
-    | 0 -> ()
-    | n ->
+    | 0 -> ()    | n ->
         validate_once
           ~cont_ok:(fun () -> required (pred n))
           ~cont_failure:(fun event ->
 			   if particle.part_nullable then ()
 			   else
-			     error ~ctx (sprintf "Unexpected content: %s"
-					   (string_of_event event)))
+			     error (sprintf "Unexpected content: %s"
+				      (string_of_event event)))
   in
   let rec optional = function
     | None ->
@@ -482,7 +480,6 @@ and validate_all_group ctx particles =
   let tbl = Atoms.mk_map
     (List.map (fun (p,slot) -> p.part_first, (p,slot)) slots) in
   
-  let contents = ref Value.nil in
   let rec aux () =
     match peek ctx with
       | E_start_tag q ->

types/patterns.ml

@@ -334,7 +334,7 @@ and filter_prod ?kind fv p1 p2 t =
 and filter_node t p : Types.Positive.v id_map =
   try MemoFilter.find (t,p) !memo_filter
   with Not_found ->
-    let (_,fv,_) as d = descr p in
+    let (_,fv,_) = descr p in
     let res = IdMap.map_from_slist (fun _ -> Types.Positive.forward ()) fv in
     memo_filter := MemoFilter.add (t,p) res !memo_filter;
     let r = filter_descr t (descr p) in
@@ -364,7 +364,7 @@ module Factorize = struct
 [DEBUG:approx]
 x=(1,2)
 *)
-  let rec approx_var seen ((a,fv,d) as p) t xs =
+  let rec approx_var seen (a,fv,d) t xs =
 (*    assert (Types.subtype t a); 
       assert (IdSet.subset xs fv); *)
     if (IdSet.is_empty xs) || (Types.is_empty t) then xs
@@ -400,7 +400,7 @@ x=(1,2)
       
 
 (* Obviously not complete ! *)      
-  let rec approx_nil seen ((a,fv,d) as p) t xs =
+  let rec approx_nil seen (a,fv,d) t xs =
     assert (Types.subtype t a); 
     assert (IdSet.subset xs fv);
     if (IdSet.is_empty xs) || (Types.is_empty t) then xs
@@ -661,7 +661,7 @@ module Normal = struct
   let nconstant lab x c = nany lab (IdMap.singleton x (SConst c))
   let ncapture lab x = nany lab (IdMap.singleton x SCatch)
 
-  let rec nnormal lab ((acc,fv,d) as p) xs =
+  let rec nnormal lab (acc,fv,d) xs =
     let xs = IdSet.cap xs fv in
     if Types.is_empty acc then nempty lab
     else if IdSet.is_empty xs then nconstr lab acc

types/sortedList.ml

@@ -213,7 +213,7 @@ module Map = struct
 
   let rec cap f l1 l2 =
     match (l1,l2) with
-      | ((x1,y1) as t1)::q1, ((x2,y2) as t2)::q2 ->
+      | (x1,y1)::q1, (x2,y2)::q2 ->
           let c = X.compare x1 x2 in
           if c = 0 then (x1,(f y1 y2))::(cap f q1 q2)
           else if c < 0 then cap f q1 l2
@@ -222,7 +222,7 @@ module Map = struct
 
   let rec sub f l1 l2 =
     match (l1,l2) with
-      | ((x1,y1) as t1)::q1, ((x2,y2) as t2)::q2 ->
+      | ((x1,y1) as t1)::q1, (x2,y2)::q2 ->
           let c = X.compare x1 x2 in
           if c = 0 then (x1,(f y1 y2))::(sub f q1 q2)
           else if c < 0 then t1::(sub f q1 l2)

types/types.ml

@@ -1094,7 +1094,7 @@ struct
       if l == Label.dummy then
 	let (some1,none1) = empty_cases d1 
 	and (some2,none2) = empty_cases d2 in
-	let none = none1 && none2 and some = some1 || some2 in
+	let _none = none1 && none2 and some = some1 || some2 in
 	let accu = LabelMap.from_list (fun _ _ -> assert false) accu in
 	(* approx for the case (some && not none) ... *)
 	res := cup !res (record_fields (some, accu))

typing/typepat.ml

@@ -172,7 +172,7 @@ let deferr s = raise (Patterns.Error s)
     | IRecord (_,r,_) -> LabelMap.iter (iter_field f) r
     | _ -> ()
 
-  let minimize ((mem,add) as h) =
+  let minimize (mem,add) =
     let rec aux n =
       let n = repr n in
       if mem n then () else (

typing/typer.ml

@@ -414,7 +414,6 @@ module IType = struct
 	   if (loc <> noloc) && (Types.is_empty t) then
 	     warning loc 
 	       ("This definition yields an empty type for " ^ (U.to_string v));
-	   let v = ident env loc v in
 	   (v',t)) b b' in
     List.iter (fun (v,t) -> Types.Print.register_global "" v t) b;
     enter_types b env
@@ -1018,7 +1017,6 @@ and type_check_string loc env ofs s i j e constr precise =
     if Types.Product.is_empty rects 
     then should_have_str loc ofs constr "but it is a string"
     else
-      let need_s = Types.Product.need_second rects in
       let (ch,i') = U.next s i in
       let ch = Chars.V.mk_int ch in
       let tch = Types.constant (Types.Char ch) in