-4.02.2+rc1
+4.02.2
# The version string is the first line of this file.
# It must be in the format described in stdlib/sys.mli
+++ /dev/null
-Patch taken from:
- https://github.com/mshinwell/ocaml/commits/4.02-block-bounds
-
-diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
-index 01eff9c..b498b58 100644
---- a/asmcomp/cmmgen.ml
-+++ b/asmcomp/cmmgen.ml
-@@ -22,6 +22,13 @@ open Clambda
- open Cmm
- open Cmx_format
-
-+let do_check_field_access = true
-+(*
-+ match try Some (Sys.getenv "BOUNDS") with Not_found -> None with
-+ | None | Some "" -> false
-+ | Some _ -> true
-+*)
-+
- (* Local binding of complex expressions *)
-
- let bind name arg fn =
-@@ -494,6 +501,35 @@ let get_tag ptr =
- let get_size ptr =
- Cop(Clsr, [header ptr; Cconst_int 10])
-
-+(* Bounds checks upon field access, for debugging the compiler *)
-+
-+let check_field_access ptr field_index if_success =
-+ if not do_check_field_access then
-+ if_success
-+ else
-+ let field_index = Cconst_int field_index in
-+ (* If [ptr] points at an infix header, we need to move it back to the "main"
-+ [Closure_tag] header. *)
-+ let ptr =
-+ Cifthenelse (Cop (Ccmpi Cne, [get_tag ptr; Cconst_int Obj.infix_tag]),
-+ ptr,
-+ Cop (Csuba, [ptr;
-+ Cop (Cmuli, [get_size ptr (* == Infix_offset_val(ptr) *);
-+ Cconst_int size_addr])]))
-+ in
-+ let not_too_small = Cop (Ccmpi Cge, [field_index; Cconst_int 0]) in
-+ let not_too_big = Cop (Ccmpi Clt, [field_index; get_size ptr]) in
-+ let failure =
-+ Cop (Cextcall ("caml_field_access_out_of_bounds_error", typ_addr, false,
-+ Debuginfo.none),
-+ [ptr; field_index])
-+ in
-+ Cifthenelse (not_too_small,
-+ Cifthenelse (not_too_big,
-+ if_success,
-+ failure),
-+ failure)
-+
- (* Array indexing *)
-
- let log2_size_addr = Misc.log2 size_addr
-@@ -1550,13 +1586,18 @@ and transl_prim_1 p arg dbg =
- return_unit(remove_unit (transl arg))
- (* Heap operations *)
- | Pfield n ->
-- get_field (transl arg) n
-+ let ptr = transl arg in
-+ let body = get_field ptr n in
-+ check_field_access ptr n body
- | Pfloatfield n ->
- let ptr = transl arg in
-- box_float(
-- Cop(Cload Double_u,
-- [if n = 0 then ptr
-- else Cop(Cadda, [ptr; Cconst_int(n * size_float)])]))
-+ let body =
-+ box_float(
-+ Cop(Cload Double_u,
-+ [if n = 0 then ptr
-+ else Cop(Cadda, [ptr; Cconst_int(n * size_float)])]))
-+ in
-+ check_field_access ptr n body
- | Pint_as_pointer ->
- Cop(Cadda, [transl arg; Cconst_int (-1)])
- (* Exceptions *)
-@@ -1649,20 +1690,25 @@ and transl_prim_1 p arg dbg =
- and transl_prim_2 p arg1 arg2 dbg =
- match p with
- (* Heap operations *)
-- Psetfield(n, ptr) ->
-- if ptr then
-- return_unit(Cop(Cextcall("caml_modify", typ_void, false,Debuginfo.none),
-- [field_address (transl arg1) n; transl arg2]))
-- else
-- return_unit(set_field (transl arg1) n (transl arg2))
-+ Psetfield(n, is_ptr) ->
-+ let ptr = transl arg1 in
-+ let body =
-+ if is_ptr then
-+ Cop(Cextcall("caml_modify", typ_void, false,Debuginfo.none),
-+ [field_address ptr n; transl arg2])
-+ else
-+ set_field ptr n (transl arg2)
-+ in
-+ check_field_access ptr n (return_unit body)
- | Psetfloatfield n ->
- let ptr = transl arg1 in
-- return_unit(
-+ let body =
- Cop(Cstore Double_u,
- [if n = 0 then ptr
- else Cop(Cadda, [ptr; Cconst_int(n * size_float)]);
-- transl_unbox_float arg2]))
--
-+ transl_unbox_float arg2])
-+ in
-+ check_field_access ptr n (return_unit body)
- (* Boolean operations *)
- | Psequand ->
- Cifthenelse(test_bool(transl arg1), transl arg2, Cconst_int 1)
-diff --git a/asmrun/fail.c b/asmrun/fail.c
-index cb2c1cb..4f67c74 100644
---- a/asmrun/fail.c
-+++ b/asmrun/fail.c
-@@ -15,6 +15,7 @@
-
- #include <stdio.h>
- #include <signal.h>
-+#include <assert.h>
- #include "alloc.h"
- #include "fail.h"
- #include "io.h"
-@@ -180,3 +181,20 @@ int caml_is_special_exception(value exn) {
- || exn == (value) caml_exn_Assert_failure
- || exn == (value) caml_exn_Undefined_recursive_module;
- }
-+
-+void caml_field_access_out_of_bounds_error(value v_block, intnat index)
-+{
-+ assert(Is_block(v_block));
-+ fprintf(stderr, "Fatal error: out-of-bounds access to field %ld ", index);
-+ fprintf(stderr, "of block at %p (%s, size %ld, tag %d)\n",
-+ (void*) v_block,
-+ Is_young(v_block) ? "in minor heap"
-+ : Is_in_heap(v_block) ? "in major heap"
-+ : Is_in_value_area(v_block) ? "in static data"
-+ : "out-of-heap",
-+ (long) Wosize_val(v_block), (int) Tag_val(v_block));
-+ fflush(stderr);
-+ /* This error may have occurred in places where it is not reasonable to
-+ attempt to continue. */
-+ abort();
-+}
+++ /dev/null
-#!/bin/sh
-
-#######################################################################
-# #
-# OCaml #
-# #
-# Damien Doligez, projet Gallium, INRIA Rocquencourt #
-# #
-# Copyright 2011 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#######################################################################
-
-(
-case $# in
- 0) find . -type f -print;;
- *) echo $1;;
-esac
-) | \
-while read f; do
-awk -f - "$f" <<\EOF
-
-function checkline (x) {
- return ( $0 ~ ("^.{0,4}" x) );
-}
-
-function hrule () {
- return (checkline("[*#]{69}"));
-}
-
-function blank () {
- return (checkline(" {69}"));
-}
-
-function ocaml () {
- return (checkline(" {32}OCaml {32}") \
- || checkline(" {35}OCaml {32}") \
- || checkline(" ocamlbuild ") \
- || checkline(" OCamldoc ") \
- );
-}
-
-function any () {
- return (checkline(".{69}"));
-}
-
-function copy1 () {
- return (checkline(" Copyright +[-0-9]+ +Institut +National +de +Recherche +en +Informatique +et "));
-}
-
-function copy2 () {
- return (checkline(" en Automatique"));
-}
-
-function err () {
- printf ("File \"%s\", line %d:\n", FILENAME, FNR);
- printf (" Error: line %d of header is wrong.\n", FNR + offset);
- print $0;
-}
-
-function add_ignore_re (x) {
- ignore_re[++ignore_re_index] = x;
-}
-
-function add_exception (x) {
- exception[++exception_index] = x;
-}
-
-FNR == 1 {
- offset = 0;
- add_ignore_re("/\\.svn/");
- add_ignore_re("/\\.depend(\\.nt)?$");
- add_ignore_re("/\\.ignore$");
- add_ignore_re("\\.gif$");
- add_ignore_re("/[A-Z]*$");
- add_ignore_re("/README\\.[^/]*$");
- add_ignore_re("/Changes$");
- add_ignore_re("\\.mlpack$");
- add_ignore_re("\\.mllib$");
- add_ignore_re("\\.mltop$");
- add_ignore_re("\\.clib$");
- add_ignore_re("\\.odocl$");
- add_ignore_re("\\.itarget$");
- add_ignore_re("^\\./boot/");
- add_ignore_re("^\\./camlp4/test/");
- add_ignore_re("^\\./camlp4/unmaintained/");
- add_ignore_re("^\\./config/gnu/");
- add_ignore_re("^\\./experimental/");
- add_ignore_re("^\\./ocamlbuild/examples/");
- add_ignore_re("^\\./ocamlbuild/test/");
- add_ignore_re("^\\./testsuite/");
- for (i in ignore_re){
- if (FILENAME ~ ignore_re[i]) { nextfile; }
- }
- add_exception("./asmrun/m68k.S"); # obsolete
- add_exception("./build/camlp4-bootstrap-recipe.txt");
- add_exception("./build/new-build-system");
- add_exception("./ocamlbuild/ChangeLog");
- add_exception("./ocamlbuild/manual/myocamlbuild.ml"); # TeX input file ?
- add_exception("./ocamlbuild/manual/trace.out"); # TeX input file
- add_exception("./ocamldoc/Changes.txt");
- add_exception("./ocamldoc/ocamldoc.sty"); # public domain
- add_exception("./tools/objinfo_helper.c"); # non-INRIA
- add_exception("./tools/magic"); # public domain ?
- add_exception("./Upgrading");
- add_exception("./win32caml/inriares.h"); # generated
- add_exception("./win32caml/ocaml.rc"); # generated
- add_exception("./win32caml/resource.h"); # generated
- for (i in exception){
- if (FILENAME == exception[i]) { nextfile; }
- }
-}
-
-# 1 [!hrule] #!
-# 2 [!hrule] empty
-# 3 hrule
-# 4 [blank]
-# 5 ocaml title
-# 6 blank
-# 7 any author
-# 8 [!blank] author
-# 9 [!blank] author
-#10 blank
-#11 copy1 copyright
-#12 copy2 copyright
-#13 any copyright
-#14 [!blank] copyright
-#15 [!blank] copyright
-#16 blank
-#17 hrule
-
-FNR + offset == 1 && hrule() { ++offset; }
-FNR + offset == 2 && hrule() { ++offset; }
-FNR + offset == 3 && ! hrule() { err(); nextfile; }
-FNR + offset == 4 && ! blank() { ++offset; }
-FNR + offset == 5 && ! ocaml() { err(); nextfile; }
-FNR + offset == 6 && ! blank() { err(); nextfile; }
-FNR + offset == 7 && ! any() { err(); nextfile; }
-FNR + offset == 8 && blank() { ++offset; }
-FNR + offset == 9 && blank() { ++offset; }
-FNR + offset ==10 && ! blank() { err(); nextfile; }
-FNR + offset ==11 && ! copy1() { err(); nextfile; }
-FNR + offset ==12 && ! copy2() { err(); nextfile; }
-FNR + offset ==13 && ! any() { err(); nextfile; }
-FNR + offset ==14 && blank() { ++offset; }
-FNR + offset ==15 && blank() { ++offset; }
-FNR + offset ==16 && ! blank() { err(); nextfile; }
-FNR + offset ==17 && ! hrule() { err(); nextfile; }
-
-EOF
-done
+++ /dev/null
-ROOT=../..
-OCAMLC=$(ROOT)/boot/ocamlrun $(ROOT)/ocamlc -I $(ROOT)/stdlib -I $(ROOT)/parsing -I $(ROOT)/utils -I $(ROOT)/tools -I $(ROOT)/typing -I $(ROOT)/driver -I $(ROOT)/toplevel -w A-4-9-42
-COMMON=$(ROOT)/compilerlibs/ocamlcommon.cma
-BYTECMP=$(ROOT)/compilerlibs/ocamlbytecomp.cma
-TOPLVL=$(ROOT)/compilerlibs/ocamltoplevel.cma
-
-clean:
- rm -f *.exe *.cm* *~
-
-## Detecting unused exported values
-
-.PHONY: unused_exported_values
-unused_exported_values:
- $(OCAMLC) -o unused_exported_values.exe $(COMMON) $(ROOT)/tools/tast_iter.cmo unused_exported_values.ml
-
-
-## Conditional compilation based on environment variables
-
-.PHONY: ifdef
-ifdef:
- $(OCAMLC) -o ifdef.exe $(COMMON) ifdef.ml
- $(OCAMLC) -o test_ifdef.exe -ppx ./ifdef.exe -dsource test_ifdef.ml
- ./test_ifdef.exe
-
-## A proposal for replacing js_of_ocaml Camlp4 syntax extension with
-## a -ppx filter
-
-.PHONY: js_syntax
-js_syntax:
- $(OCAMLC) -o js_syntax.exe $(COMMON) js_syntax.ml
- $(OCAMLC) -o test_ifdef.exe -i -ppx ./js_syntax.exe test_js.ml
-
-
-## A "toy" ocamldoc clone based on .cmti files
-
-.PHONY: minidoc
-minidoc:
- $(OCAMLC) -custom -o minidoc.exe $(COMMON) minidoc.ml
- $(OCAMLC) -c -bin-annot testdoc.mli
- ./minidoc.exe testdoc.cmti
-
-## Using the OCaml toplevel to evaluate expression during compilation
-
-.PHONY: eval
-eval:
- $(OCAMLC) -linkall -o eval.exe $(COMMON) $(BYTECMP) $(TOPLVL) eval.ml
- $(OCAMLC) -o test_eval.exe -ppx ./eval.exe test_eval.ml
- ./test_eval.exe
-
-## Example of code generation based on type declarations
-
-.PHONY: ppx_builder
-ppx_builder:
- $(OCAMLC) -linkall -o ppx_builder.exe $(COMMON) ppx_builder.ml
- $(OCAMLC) -o test_builder.exe -ppx ./ppx_builder.exe -dsource test_builder.ml
-
-## Import type definitions from other source files (e.g. to avoid code
-## duplication between the .ml and .mli files)
-
-.PHONY: copy_typedef
-copy_typedef:
- $(OCAMLC) -linkall -o copy_typedef.exe $(COMMON) copy_typedef.ml
- $(OCAMLC) -c -ppx ./copy_typedef.exe test_copy_typedef.mli
- $(OCAMLC) -o test_copy_typedef.exe -ppx ./copy_typedef.exe -dsource test_copy_typedef.ml
-
-
-## Create mli files from ml files
-
-.PHONY: nomli
-nomli:
- $(OCAMLC) -linkall -o nomli.exe $(COMMON) $(BYTECMP) ../../tools/untypeast.cmo ../../tools/tast_iter.cmo nomli.ml
- ./nomli.exe test_nomli.ml
-
-## A port of pa_matches
-
-.PHONY: matches
-matches:
- $(OCAMLC) -linkall -o ppx_matches.exe $(COMMON) ppx_matches.ml
- $(OCAMLC) -c -dsource -ppx ./ppx_matches.exe test_matches.ml
+++ /dev/null
-(*
- A -ppx rewriter to copy type definitions from the interface into
- the implementation.
-
- In an .ml file, you can write:
-
- type t = [%copy_typedef]
-
- and the concrete definition will be copied from the corresponding .mli
- file (looking for the type name in the same path).
-
- The same is available for module types:
-
- module type S = [%copy_typedef]
-
- You can also import a definition from an arbitrary .ml/.mli file.
- Example:
-
- type loc = [%copy_typedef "../../parsing/location.mli" t]
-
- Note: the definitions are imported textually without any substitution.
-*)
-
-module Main : sig end = struct
- open Asttypes
- open! Location
- open Parsetree
-
- let fatal loc s =
- Location.print_error Format.err_formatter loc;
- prerr_endline ("** copy_typedef: " ^ Printexc.to_string s);
- exit 2
-
- class maintain_path = object(this)
- inherit Ast_mapper.mapper as super
-
- val path = []
-
- method! module_binding m = {< path = m.pmb_name.txt :: path >} # super_module_binding m
- method super_module_binding = super # module_binding
-
- method! module_declaration m = {< path = m.pmd_name.txt :: path >} # super_module_declaration m
- method super_module_declaration = super # module_declaration
-
- method! module_type_declaration m = {< path = m.pmtd_name.txt :: path >} # super_module_type_declaration m
- method super_module_type_declaration = super # module_type_declaration
-
- method! structure_item s =
- let s =
- match s.pstr_desc with
- | Pstr_type tdecls -> {s with pstr_desc=Pstr_type (List.map (this # tydecl) tdecls)}
- | Pstr_modtype mtd -> {s with pstr_desc=Pstr_modtype (this # mtydecl mtd)}
- | _ -> s
- in
- super # structure_item s
-
- method! signature_item s =
- let s =
- match s.psig_desc with
- | Psig_type tdecls -> {s with psig_desc=Psig_type (List.map (this # tydecl) tdecls)}
- | Psig_modtype mtd -> {s with psig_desc=Psig_modtype (this # mtydecl mtd)}
- | _ -> s
- in
- super # signature_item s
-
- method tydecl x = x
- method mtydecl x = x
- end
-
- let memoize f =
- let h = Hashtbl.create 16 in
- fun x ->
- try Hashtbl.find h x
- with Not_found ->
- let r = f x in
- Hashtbl.add h x r;
- r
-
- let from_file file =
- let types = Hashtbl.create 16 in
- let mtypes = Hashtbl.create 16 in
- let collect = object
- inherit maintain_path
- method! tydecl x =
- Hashtbl.add types (path, x.ptype_name.txt) x;
- x
- method! mtydecl x =
- Hashtbl.add mtypes (path, x.pmtd_name.txt) x;
- x
- end
- in
- let ic = open_in file in
- let lexbuf = Lexing.from_channel ic in
- if Filename.check_suffix file ".ml"
- then ignore (collect # structure (Parse.implementation lexbuf))
- else if Filename.check_suffix file ".mli"
- then ignore (collect # signature (Parse.interface lexbuf))
- else failwith (Printf.sprintf "Unknown extension for %s" file);
- close_in ic;
- object
- method tydecl path name =
- try Hashtbl.find types (path, name)
- with Not_found ->
- failwith
- (Printf.sprintf "Cannot find type %s in file %s\n%!"
- (String.concat "." (List.rev (name :: path))) file)
-
- method mtydecl path name =
- try Hashtbl.find mtypes (path, name)
- with Not_found ->
- failwith
- (Printf.sprintf "Cannot find module type %s in file %s\n%!"
- (String.concat "." (List.rev (name :: path))) file)
- end
-
- let from_file = memoize from_file
-
- let copy = object(this)
- inherit maintain_path as super
-
- val mutable file = ""
-
- method source name = function
- | PStr [] ->
- let file =
- if Filename.check_suffix file ".ml"
- then (Filename.chop_suffix file ".ml") ^ ".mli"
- else if Filename.check_suffix file ".mli"
- then (Filename.chop_suffix file ".mli") ^ ".ml"
- else failwith "Unknown source extension"
- in
- file, path, name
- | PStr [{pstr_desc=Pstr_eval
- ({pexp_desc=Pexp_apply
- ({pexp_desc=Pexp_constant(Const_string (file, _)); _},
- ["", {pexp_desc=Pexp_ident{txt=lid;_}; _}]); _}, _); _}] ->
- begin match List.rev (Longident.flatten lid) with
- | [] -> assert false
- | name :: path -> file, path, name
- end
- | _ ->
- failwith "Cannot parse argument"
-
- method! tydecl = function
- | {ptype_kind = Ptype_abstract;
- ptype_manifest =
- Some{ptyp_desc=Ptyp_extension({txt="copy_typedef";_}, arg); _};
- ptype_name = name; ptype_loc = loc; _
- } ->
- begin try
- let (file, path, x) = this # source name.txt arg in
- {((from_file file) # tydecl path x)
- with ptype_name = name; ptype_loc = loc}
- with exn -> fatal loc exn
- end
- | td -> td
-
- method! mtydecl = function
- | {pmtd_type = Some{pmty_desc=Pmty_extension({txt="copy_typedef";_}, arg);
- pmty_loc=loc; _};
- pmtd_name = name; _
- } ->
- begin try
- let (file, path, x) = this # source name.txt arg in
- {((from_file file) # mtydecl path x)
- with pmtd_name = name}
- with exn -> fatal loc exn
- end
- | td -> td
-
- method! implementation f x =
- file <- f;
- super # implementation f x
-
- method! interface f x =
- file <- f;
- super # interface f x
- end
-
- let () = Ast_mapper.main copy
-end
+++ /dev/null
-(* A -ppx rewriter which evaluates expressions at compile-time,
- using the OCaml toplevel interpreter.
-
- The following extensions are supported:
-
- [%eval e] in expression context: the expression e will be evaluated
- at compile time, and the resulting value will be inserted as a
- constant literal.
-
- [%%eval.start] as a structure item: forthcoming structure items
- until the next [%%eval.stop] will be evaluated at compile time (the
- result is ignored) only.
-
- [%%eval.start both] as a structure item: forthcoming structure
- items until the next [%%eval.stop] will be evaluated at compile
- time (the result is ignored), but also kept in the compiled unit.
-
- [%%eval.load "..."] as a structure item: load the specified
- .cmo unit or .cma library, so that it can be used in the forthcoming
- compile-time components.
-*)
-
-
-module Main : sig end = struct
-
- open Location
- open Parsetree
- open Ast_helper
- open Outcometree
- open Ast_helper.Convenience
-
- let rec lid_of_out_ident = function
- | Oide_apply _ -> assert false
- | Oide_dot (x, s) -> lid_of_out_ident x ^ "." ^ s
- | Oide_ident s -> s
-
- let rec exp_of_out_value = function
- | Oval_string x -> str x
- | Oval_int x -> int x
- | Oval_char x -> char x
- | Oval_float x -> Ast_helper.Convenience.float x
- | Oval_list l -> list (List.map exp_of_out_value l)
- | Oval_array l -> Exp.array (List.map exp_of_out_value l)
- | Oval_constr (c, args) -> constr (lid_of_out_ident c) (List.map exp_of_out_value args)
- | Oval_record l ->
- record
- (List.map
- (fun (s, v) -> lid_of_out_ident s, exp_of_out_value v) l)
- | v ->
- Format.eprintf "[%%eval] cannot map value to expression:@.%a@."
- !Toploop.print_out_value
- v;
- exit 2
-
- let empty_str_item = Str.include_ (Mod.structure [])
-
- let run phr =
- try Toploop.execute_phrase true Format.err_formatter phr
- with exn ->
- Errors.report_error Format.err_formatter exn;
- exit 2
-
- let get_exp loc = function
- | PStr [ {pstr_desc=Pstr_eval (e, _); _} ] -> e
- | _ ->
- Format.eprintf "%aExpression expected@."
- Location.print_error loc;
- exit 2
-
- let eval _args =
- let open Ast_mapper in
- let eval_str_items = ref None in
- let super = default_mapper in
- let my_structure_item this i =
- match i.pstr_desc with
- | Pstr_extension(({txt="eval.load";loc}, e0), _) ->
- let e0 = get_exp loc e0 in
- let s =
- match get_str e0 with
- | Some s -> s
- | None ->
- Location.print_error Format.err_formatter e0.pexp_loc;
- Format.eprintf "string literal expected";
- exit 2
- in
- if not (Topdirs.load_file Format.err_formatter s) then begin
- Location.print Format.err_formatter e0.pexp_loc;
- exit 2;
- end;
- empty_str_item
- | Pstr_extension(({txt="eval.start";_},
- PStr [{pstr_desc=Pstr_eval (e, _);_}]
- ), _) when get_lid e = Some "both" ->
- eval_str_items := Some true;
- empty_str_item
- | Pstr_extension(({txt="eval.start";_}, PStr []), _) ->
- eval_str_items := Some false;
- empty_str_item
- | Pstr_extension(({txt="eval.stop";_}, PStr []), _) ->
- eval_str_items := None;
- empty_str_item
- | _ ->
- let s = super.structure_item this i in
- match !eval_str_items with
- | None -> s
- | Some both ->
- if not (run (Ptop_def [s])) then begin
- Location.print_error Format.err_formatter s.pstr_loc;
- Format.eprintf "this structure item raised an exception@.";
- exit 2
- end;
- if both then s else empty_str_item
- in
- let my_expr this e =
- match e.pexp_desc with
- | Pexp_extension({txt="eval";loc}, e0) ->
- let e0 = get_exp loc e0 in
- let last_result = ref None in
- let pop = !Toploop.print_out_phrase in
- Toploop.print_out_phrase := begin fun _ppf -> function
- | Ophr_eval (v, _) -> last_result := Some v
- | r ->
- Location.print_error Format.err_formatter e.pexp_loc;
- Format.eprintf "error while evaluating expression:@.%a@."
- pop
- r;
- exit 2
- end;
- assert (run (Ptop_def [Str.eval e0]));
- Toploop.print_out_phrase := pop;
- let v = match !last_result with None -> assert false | Some v -> v in
- with_default_loc e0.pexp_loc (fun () -> exp_of_out_value v)
- | _ ->
- super.expr this e
- in
- Toploop.initialize_toplevel_env ();
- {super with expr = my_expr; structure_item = my_structure_item}
-
-
- let () = Ast_mapper.run_main eval
-end
+++ /dev/null
-This file describes the changes on the extension_points branch.
-
-
-=== Attributes
-
-Attributes are "decorations" of the syntax tree which are ignored by
-the type-checker. An attribute is made of an identifier (written id below)
-and a payload (written s below).
-
- * The identifier 'id' can be a lowercase or uppercase identifier
- (including OCaml keywords) or a sequence of such atomic identifiers
- separated with a dots (whitespaces are allowed around the dots).
- In the Parsetree, the identifier is represented as a single string
- (without spaces).
-
- * The payload 's' can be one of three things:
-
- - An OCaml structure (i.e. a list of structure items). Note that a
- structure can be empty or reduced to a single expression.
-
- [@id]
- [@id x + 3]
- [@id type t = int]
-
- - A type expression, prefixed with the ":" character.
-
- [@id : TYP]
-
- - A pattern, prefixed with the "?" character, and optionally followed
- by a "when" clause:
-
- [@id ? PAT]
- [@id ? PAT when EXPR]
-
-
-Attributes on expressions, type expressions, module expressions, module type expressions,
-patterns, class expressions, class type expressions:
-
- ... [@id s]
-
-The same syntax [@id s] is also available to add attributes on
-constructors and labels in type declarations:
-
- type t =
- | A [@id1]
- | B [@id2] of int [@id3]
-
-Here, id1 (resp. id2) is attached to the constructor A (resp. B)
-and id3 is attached to the int type expression. Example on records:
-
- type t =
- {
- x [@id1]: int;
- mutable y [@id2] [@id3]: string [@id4];
- }
-
-
-Attributes on items:
-
- ... [@@id s]
-
- Items designate:
- - structure and signature items (for type declarations, recursive modules, class
- declarations and class type declarations, each component has its own attributes)
- - class fields and class type fields
- - each binding in a let declaration (for let structure item, local let-bindings in
- expression and class expressions)
-
- For instance, consider:
-
- type t1 = ... [@@id1] [@@id2] and t2 = ... [@@id3] [@@id4]
-
- Here, the attributes on t1 are id1, id23; the attributes on
- t2 are id3 and id4.
-
- Similarly for:
-
- let x1 = ... [@@id1] [@@id2] and x2 = ... [@@id3] [@@id4]
-
-
-Floating attributes:
-
- The [@@@id s] form defines an attribute which stands as a
- stand-alone signature or structure item (not attached to another
- item).
-
- Example:
-
- module type S = sig
- [@@id1]
- type t
- [@@id2]
- [@@@id3] [@@@id4]
- [@@@id5]
- type s
- [@@id6]
- end
-
- Here, id1, id3, id4, id5 are floating attributes, while
- id2 is attached to the type t and id6 is attached to the type s.
-
-=== Extension nodes
-
-Extension nodes replace valid components in the syntax tree. They are
-normally interpreted and expanded by AST mapper. The type-checker
-fails when it encounters such an extension node. An extension node is
-made of an identifier (an "LIDENT", written id below) and an optional
-expression (written expr below).
-
-Two syntaxes exist for extension node:
-
-As expressions, type expressions, module expressions, module type expressions,
-patterns, class expressions, class type expressions:
-
- [%id s]
-
-As structure item, signature item, class field, class type field:
-
- [%%id s]
-
-As other structure item, signature item, class field or class type
-field, attributes can be attached to a [%%id s] extension node.
-
-
-
-=== Alternative syntax for attributes and extensions on specific kinds of nodes
-
-All expression constructions starting with a keyword (EXPR = KW REST) support an
-alternative syntax for attributes and/or extensions:
-
- KW[@id s]...[@id s] REST
- ---->
- EXPR[@id s]...[@id s]
-
- KW%id REST
- ---->
- [%id EXPR]
-
- KW%id[@id s]...[@id s] REST
- ---->
- [%id EXPR[@id s]...[@id s]]
-
-
-where KW can stand for:
- assert
- begin
- for
- fun
- function
- if
- lazy
- let
- let module
- let open
- match
- new
- object
- try
- while
-
-
-For instance:
-
-let[@foo] x = 2 in x + 1 ==== (let x = 2 in x + 1)[@foo]
-begin[@foo] ... end ==== (begin ... end)[@foo]
-match%foo e with ... ==== [%foo match e with ...]
-
-
-The let-binding form of structure items also supports this form:
-
-let%foo x = ... ==== [%%foo let x = ...]
-
-=== Quoted strings
-
-Quoted strings gives a different syntax to write string literals in
-OCaml code. This will typically be used to support embedding pieces
-of foreign syntax fragments (to be interpret by a -ppx filter or just
-a library) in OCaml code.
-
-The opening delimiter has the form {id| where id is a (possibly empty)
-sequence of lowercase letters. The corresponding closing delimiter is
-|id} (the same identifier). Contrary to regular OCaml string
-literals, quoted strings don't interpret any character in a special
-way.
-
-Example:
-
-String.length {|\"|} (* returns 2 *)
-String.length {foo|\"|foo} (* returns 2 *)
-
-
-The fact that a string literal comes from a quoted string is kept in
-the Parsetree representation. The Astypes.Const_string constructor is
-now defined as:
-
- | Const_string of string * string option
-
-where the "string option" represents the delimiter (None for a string
-literal with the regular syntax).
-
-
-=== Representation of attributes in the Parsetree
-
-Attributes as standalone signature/structure items are represented
-by a new constructor:
-
- | Psig_attribute of attribute
- | Pstr_attribute of attribute
-
-Most other attributes are stored in an extra field in their record:
-
-and expression = {
- ...
- pexp_attributes: attribute list;
- ...
-}
-and type_declaration = {
- ...
- ptype_attributes: attribute list;
- ...
-}
-
-In a previous version, attributes on expressions (and types, patterns,
-etc) used to be stored as a new constructor. The current choice makes
-it easier to pattern match on structured AST fragments while ignoring
-attributes.
-
-For open/include signature/structure items and exception rebind
-structure item, the attributes are stored directly in the constructor
-of the item:
-
- | Pstr_open of Longident.t loc * attribute list
-
-
-=== Attributes in the Typedtree
-
-The Typedtree representation has been updated to follow closely the
-Parsetree, and attributes are kept exactly as in the Parsetree. This
-can allow external tools to process .cmt/.cmti files and process
-attributes in them. An example of a mini-ocamldoc based on this
-technique is in experimental/frisch/minidoc.ml.
-
-
-=== Other changes to the parser and Parsetree
-
---- Introducing Ast_helper module
-
-This module simplifies the creation of AST fragments, without having to
-touch the concrete type definitions of Parsetree. Record and sum types
-are encapsulated in builder functions, with some optional arguments, e.g.
-to represent attributes.
-
---- Relaxing the syntax for signatures and structures
-
-It is now possible to start a signature or a structure with a ";;" token and to have two successive ";;" tokens.
-
-Rationale:
- In an intermediate version of this branch, floating attributes shared
- the same syntax as item attributes, with the constraints that they
- had to appear either at the beginning of their structure or signature,
- or after ";;". The relaxation above made is possible to always prefix
- a floating attributes by ";;" independently of its context.
-
- Floating attributes now have a custom syntax [@@@id], but this changes
- is harmless, and the same argument holds for toplevel expressions:
- it is always possile to write:
-
- ;; print_endline "bla";;
-
- without having to care about whether the previous structure item
- ends with ";;" or not.
-
-
--- Relaxing the syntax for exception declarations
-
-The parser now accepts the same syntax for exceptioon declarations as for constructor declarations,
-which permits the GADT syntax:
-
- exception A : int -> foo
-
-The type-checker rejects this form. Note that it is also possible to
-define exception whose name is () or ::.
-
-Attributes can be put on the constructor or on the whole declaration:
-
- exception A[@foo] of int [@@bar]
-
-Rationale:
- One less notion in the Parsetree, more uniform parsing. Also
- open the door to existentials in exception constructors.
-
---- Relaxing the syntax for recursive modules
-
-Before:
- module X1 : MT1 = M1 and ... and Xn : MTn = Mn
-
-Now:
- module X1 = M1 and ... and Xn = Mn
- (with the usual sugar that Xi = (Mi : MTi) can be written as Xi : MTi = Mi
- which gives the old syntax)
-
- The type-checker fails when a module expression is not of
- the form (M : MT)
-
-
-Rationale:
-
-1. More uniform representation in the Parsetree.
-
-2. The type-checker can be made more clever in the future to support
- other forms of module expressions (e.g. functions with an explicit
- constraint on its result; or a structure with only type-level
- components).
-
-
---- Turning some tuple or n-ary constructors into records
-
-Before:
-
- | Pstr_module of string loc * module_expr
-
-After:
-
- | Pstr_module of module_binding
-...
- and module_binding =
- {
- pmb_name: string loc;
- pmb_expr: module_expr;
- pmb_attributes: attribute list;
- }
-
-
-
-Rationale:
-
-More self-documented, more robust to future additions (such as
-attributes), simplifies some code.
-
-
---- Keeping names inside value_description and type_declaration
-
-Before:
-
- | Psig_type of (string loc * type_declaration) list
-
-
-After:
-
- | Psig_type of type_declaration list
-
-....
-and type_declaration =
- { ptype_name: string loc;
- ...
- }
-
-Rationale:
-
-More self-documented, simplifies some code.
-
-
---- Better representation of variance information on type parameters
-
-Introduced a new type Asttypes.variance to represent variance
-(Covariant/Contravariant/Invariant) and use it instead of bool * bool
-in Parsetree. Moreover, variance information is now attached
-directly to the parameters fields:
-
- and type_declaration =
- { ptype_name: string loc;
-- ptype_params: string loc option list;
-+ ptype_params: (string loc option * variance) list;
- ptype_cstrs: (core_type * core_type * Location.t) list;
- ptype_kind: type_kind;
- ptype_private: private_flag;
- ptype_manifest: core_type option;
-- ptype_variance: (bool * bool) list;
- ptype_attributes: attribute list;
- ptype_loc: Location.t }
-
-
---- Getting rid of 'Default' case in Astypes.rec_flag
-
-This constructor was used internally only during the compilation of
-default expression for optional arguments, in order to trigger a
-subsequent optimization (see PR#5975). This behavior is now
-implemented by creating an attribute internally (whose name "#default"
-cannot be used in real programs).
-
-Rationale:
-
- - Attributes give a way to encode information local to the
- type-checker without polluting the definition of the Parsetree.
-
---- Simpler and more faithful representation of object types
-
-- | Ptyp_object of core_field_type list
-+ | Ptyp_object of (string * core_type) list * closed_flag
-
-(and get rid of Parsetree.core_field_type)
-
-And same in the Typedtree.
-
-Rationale:
-
- - More faithful representation of the syntax really supported
- (i.e. the ".." can only be the last field).
- - One less "concept" in the Parsetree.
-
-
---- Do not require empty Ptyp_poly nodes in the Parsetree
-
-The type-checker automatically inserts Ptyp_poly node (with no
-variable) where needed. It is still allowed to put empty
-Ptyp_poly nodes in the Parsetree.
-
-Rationale:
-
- - Less chance that Ast-related code forget to insert those nodes.
-
-To be discussed: should we segrate simple_poly_type from core_type in the
-Parsetree to prevent Ptyp_poly nodes to be inserted in the wrong place?
-
-
---- Use constructor names closer to concrete syntax
-
-E.g. Pcf_cstr -> Pcf_constraint.
-
-Rationale:
-
- - Make the Parsetree more self-documented.
-
---- Merge concrete/virtual val and method constructors
-
-As in the Typedtree.
-
-- | Pcf_valvirt of (string loc * mutable_flag * core_type)
-- | Pcf_val of (string loc * mutable_flag * override_flag * expression)
-- | Pcf_virt of (string loc * private_flag * core_type)
-- | Pcf_meth of (string loc * private_flag * override_flag * expression)
-+ | Pcf_val of (string loc * mutable_flag * class_field_kind)
-+ | Pcf_method of (string loc * private_flag * class_field_kind
-...
-+and class_field_kind =
-+ | Cfk_virtual of core_type
-+ | Cfk_concrete of override_flag * expression
-+
-
---- Explicit representation of "when" guards
-
-Replaced the "(pattern * expression) list" argument of Pexp_function, Pexp_match, Pexp_try
-with "case list", with case defined as:
-
- {
- pc_lhs: pattern;
- pc_guard: expression option;
- pc_rhs: expression;
- }
-
-and get rid of Pexp_when. Idem in the Typedtree.
-
-Rationale:
-
- - Make it explicit when the guard can appear.
-
---- Get rid of "fun p when guard -> e"
-
-See #5939, #5936.
-
-
---- Get rid of the location argument on pci_params
-
-It was only used for error messages, and we get better location using
-the location of each parameter variable.
-
---- More faithful representation of "with constraint"
-
-All kinds of "with constraints" used to be represented together with a
-Longident.t denoting the constrained identifier. Now, each constraint
-keeps its own constrainted identifier, which allows us to express more
-invariants in the Parsetree (such as: := constraints cannot be on qualified
-identifiers). Also, we avoid mixing in a single Longident.t identifier
-which can be LIDENT or UIDENT.
-
---- Get rid of the "#c [> `A]" syntax
-
-See #5936, #5983.
-
---- Keep interval patterns in the Parsetree
-
-They used to be expanded into or-patterns by the parser. It is better to do
-the expansion in the type-checker to allow -ppx rewriters to see the interval
-patterns.
-
-Note: Camlp4 parsers still expand interval patterns themselves (TODO?).
-
---- Get rid of Pexp_assertfalse
-
-Do not treat specially "assert false" in the parser any more, but
-instead in the type-checker. This simplifies the Parsetree and avoids
-a potential source of confusion. Moreove, this ensures that
-attributes can be put (and used by ppx rewriters) on the "false"
-expressions. This is also more robust, since it checks that the
-condition is the constructor "false" after type-checking the condition:
-
- - if "false" is redefined (as a constructor of a different sum type),
- an error will be reported;
-
- - "extra" layers which are represented as exp_extra in the typedtree
- won't break the detection of the "false", e.g. the following will
- be recognized as "assert false":
-
- assert(false : bool)
- assert(let open X in false)
-
-Note: Camlp4's AST still has a special representation for "assert false".
-
---- Get rid of the "explicit arity" flag on Pexp_construct/Ppat_construct
-
-This Boolean was used (only by camlp5?) to indicate that the tuple
-(expression/pattern) used as the argument was intended to correspond
-to the arity of an n-ary constructor. In particular, this allowed
-the revised syntax to distinguish "A x y" from "A (x, y)" (the second one
-being wrapped in an extra fake tuple) and get a proper error message
-if "A (x, y)" was used with a constructor expecting two arguments.
-
-The feature has been preserved, but the information that a
-Pexp_construct/Ppat_constructo node has an "exact arity" is now
-propagated used as am attribute "ocaml.explicit_arity" on that node.
-
---- Split Pexp_function into Pexp_function/Pexp_fun
-
-This reflects more closely the concrete syntax and removes cases of
-Parsetree fragments which don't correspond to concrete syntax.
-
-Typedtree has not been changed.
-
-Note: Camlp4's AST has not been adapted.
-
---- Split Pexp_constraint into Pexp_constraint/Pexp_coerce
-
-Idem in the Typedtree.
-
-This reflects more closely the concrete syntax.
-
-Note: Camlp4's AST has not been adapted.
-
---- Accept abstract module type declaration in structures
-
-Previously, we could declare:
-
- module type S
-
-in signatures, but not implementations. To make the syntax, the Parsetree
-and the type-checker more uniform, this is now also allowed in structures
-(altough this is probably useless in practice).
-
-=== More TODOs
-
-- Adapt pprintast to print attributes and extension nodes.
-- Adapt Camlp4 (both its parser(s) and its internal representation of OCaml ASTs).
-- Consider adding hooks to the type-checker so that custom extension expanders can be registered (a la OCaml Templates).
-- Make the Ast_helper module more user-friendly (e.g. with optional arguments and good default values) and/or
- expose higher-level convenience functions.
-- Document Ast_helper modules.
-
-=== Use cases
-
-From https://github.com/gasche/ocaml-syntax-extension-discussion/wiki/Use-Cases
-
--- Bisect
-
- let f x =
- match List.map foo [x; a x; b x] with
- | [y1; y2; y3] -> tata
- | _ -> assert false [@bisect VISIT]
-
-;;[@@bisect IGNORE-BEGIN]
-let unused = ()
-;;[@@bisect IGNORE-END]
-
--- OCamldoc
-
-val stats : ('a, 'b) t -> statistics
-[@@doc
- "[Hashtbl.stats tbl] returns statistics about the table [tbl]:
- number of buckets, size of the biggest bucket, distribution of
- buckets by size."
-]
-[@@since "4.00.0"]
-
-;;[@@doc section 6 "Functorial interface"]
-
-module type HashedType =
- sig
- type t
- [@@doc "The type of the hashtable keys."]
- val equal : t -> t -> bool
- [@@doc "The equality predicate used to compare keys."]
- end
-
-
--- type-conv, deriving
-
-type t = {
- x : int [@default 42];
- y : int [@default 3] [@sexp_drop_default];
- z : int [@default 3] [@sexp_drop_if z_test];
-} [@@sexp]
-
-
-type r1 = {
- r1_l1 : int;
- r1_l2 : int;
-} [@@deriving (Dump, Eq, Show, Typeable, Pickle, Functor)]
-
--- camlp4 map/fold generators
-
-type variable = string
- and term =
- | Var of variable
- | Lam of variable * term
- | App of term * term
-
-
-class map = [%generate_map term]
-or:
-[%%generate_map map term]
-
-
--- ocaml-rpc
-
-type t = { foo [@rpc "type"]: int; bar [@rpc "let"]: int }
-[@@ rpc]
-
-or:
-
-type t = { foo: int; bar: int }
-[@@ rpc ("foo" > "type"), ("bar" > "let")]
-
-
-
--- pa_monad
-
-begin%monad
- a <-- [1; 2; 3];
- b <-- [3; 4; 5];
- return (a + b)
-end
-
--- pa_lwt
-
-let%lwt x = start_thread foo
-and y = start_other_thread foo in
-try%lwt
- let%for_lwt (x, y) = waiting_threads in
- compute blah
-with Killed -> bar
-
--- Bolt
-
-let funct n =
- [%log "funct(%d)" n LEVEL DEBUG];
- for i = 1 to n do
- print_endline "..."
- done
-
-
--- pre-polyrecord
-
-let r = [%polyrec x = 1; y = ref None]
-let () = [%polyrec r.y <- Some 2]
-
--- orakuda
-
-function%regexp
- | "$/^[0-9]+$/" as v -> `Int (int_of_string v#_0)
- | "$/^[a-z][A-Za-z0-9_]*$" as v -> `Variable v#_0
- | _ -> failwith "parse error"
-
--- bitstring
-
-let bits = Bitstring.bitstring_of_file "/bin/ls" in
-match%bitstring bits with
-| [ 0x7f, 8; "ELF", 24, string; (* ELF magic number *)
- e_ident, Mul(12,8), bitstring; (* ELF identifier *)
- e_type, 16, littleendian; (* object file type *)
- e_machine, 16, littleendian (* architecture *)
- ] ->
- printf "This is an ELF binary, type %d, arch %d\n"
- e_type e_machine
-
--- sedlex
-
-let rec token buf =
- let%regexp ('a'..'z'|'A'..'Z') = letter in
- match%sedlex buf with
- | number -> Printf.printf "Number %s\n" (Sedlexing.Latin1.lexeme buf); token buf
- | letter, Star ('A'..'Z' | 'a'..'z' | digit) -> Printf.printf "Ident %s\n" (Sedlexing.Latin1.lexeme buf); token buf
- | Plus xml_blank -> token buf
- | Plus (Chars "+*-/") -> Printf.printf "Op %s\n" (Sedlexing.Latin1.lexeme buf); token buf
- | Range(128,255) -> print_endline "Non ASCII"
- | eof -> print_endline "EOF"
- | _ -> failwith "Unexpected character"
-
-
--- cppo
-
-[%%ifdef DEBUG]
-[%%define debug(s) = Printf.eprintf "[%S %i] %s\n%!" __FILE__ __LINE__ s]
-[%%else]
-[%%define debug(s) = ()]
-[%%endif]
-
-debug("test")
-
-
--- PG'OCaml
-
-let fetch_users dbh =
- [%pgsql dbh "select id, name from users"]
-
-
--- Macaque
-
-let names view = [%view {name = t.name}, t <- !view]"
-
-
--- Cass
-
-let color1 = [%css{| black |}]
-let color2 = [%css{| gray |}]
-
-let button = [%css{|
- .button {
- $Css.gradient ~low:color2 ~high:color1$;
- color: white;
- $Css.top_rounded$;
- |}]
+++ /dev/null
-(* This filter implements the following extensions:
-
- In structures:
-
- [%%IFDEF X]
- ... --> included if the environment variable X is defined
- [%%ELSE]
- ... --> included if the environment variable X is undefined
- [%%END]
-
-
- In expressions:
-
- [%GETENV X] ---> the string literal representing the compile-time value
- of environment variable X
-
-
- In variant type declarations:
-
- type t =
- ..
- | C [@IFDEF X] of ... --> the constructor is kept only if X is defined
-
-
- In match clauses (function/match...with/try...with):
-
-
- P when [%IFDEF X] -> E --> the case is kept only if X is defined
-
-*)
-
-open Ast_helper
-open! Asttypes
-open Parsetree
-open Longident
-
-let getenv loc arg =
- match arg with
- | PStr [{pstr_desc=Pstr_eval({pexp_desc = Pexp_construct ({txt = Lident sym; _}, None); _}, _); _}] ->
- (try Sys.getenv sym with Not_found -> "")
- | _ ->
- Format.eprintf "%a** IFDEF: bad syntax."
- Location.print_error loc;
- exit 2
-
-let empty_str_item = Str.include_ (Mod.structure [])
-
-let ifdef _args =
- let stack = ref [] in
- let eval_attributes =
- List.for_all
- (function
- | {txt="IFDEF"; loc}, arg -> getenv loc arg <> ""
- | {txt="IFNDEF"; loc}, arg -> getenv loc arg = ""
- | _ -> true)
- in
- let filter_constr cd = eval_attributes cd.pcd_attributes in
- let open Ast_mapper in
- let super = default_mapper in
- {
- super with
-
- type_declaration =
- (fun this td ->
- let td =
- match td with
- | {ptype_kind = Ptype_variant cstrs; _} as td ->
- {td
- with ptype_kind = Ptype_variant(List.filter filter_constr cstrs)}
- | td -> td
- in
- super.type_declaration this td
- );
-
- cases =
- (fun this l ->
- let l =
- List.fold_right
- (fun c rest ->
- match c with
- | {pc_guard=Some {pexp_desc=Pexp_extension({txt="IFDEF";loc}, arg); _}; _} ->
- if getenv loc arg = "" then rest else {c with pc_guard=None} :: rest
- | c -> c :: rest
- ) l []
- in
- super.cases this l
- );
-
- structure_item =
- (fun this i ->
- match i.pstr_desc, !stack with
- | Pstr_extension(({txt="IFDEF";loc}, arg), _), _ ->
- stack := (getenv loc arg <> "") :: !stack;
- empty_str_item
- | Pstr_extension(({txt="ELSE";loc=_}, _), _), (hd :: tl) ->
- stack := not hd :: tl;
- empty_str_item
- | Pstr_extension(({txt="END";loc=_}, _), _), _ :: tl ->
- stack := tl;
- empty_str_item
- | Pstr_extension(({txt="ELSE"|"END";loc}, _), _), [] ->
- Format.printf "%a** IFDEF: mo matching [%%%%IFDEF]"
- Location.print_error loc;
- exit 2
- | _, (true :: _ | []) -> super.structure_item this i
- | _, false :: _ -> empty_str_item
- );
-
- expr =
- (fun this -> function
- | {pexp_desc = Pexp_extension({txt="GETENV";loc=l}, arg);
- pexp_loc = loc; _} ->
- Exp.constant ~loc (Const_string (getenv l arg, None))
- | x -> super.expr this x
- );
- }
-
-let () = Ast_mapper.run_main ifdef
+++ /dev/null
-(* This example shows how the AST mapping approach could be used
- instead of Camlp4 in order to give a nice syntax for js_of_ocaml
- (properties and method calls). The code below overloads regular
- syntax for field projection and assignment for Javascript
- properties, and (currified) method call for Javascript method
- calls. This is enabled under the scope of the [%js ...] extension:
-
- Get property: [%js o.x]
- Set property: [%js o.x <- e]
- Method call: [%js o#x e1 e2]
- *)
-
-open Asttypes
-open! Location
-open Parsetree
-open Longident
-open Ast_helper
-open Ast_helper.Convenience
-
-(* A few local helper functions to simplify the creation of AST nodes. *)
-let apply_ f l = app (evar f) l
-let oobject l = Typ.object_ l Open
-let annot e t = Exp.constraint_ e t
-
-
-let rnd = Random.State.make [|0x513511d4|]
-let random_var () = Format.sprintf "a%08Lx" (Random.State.int64 rnd 0x100000000L : Int64.t)
-let fresh_type () = Typ.var (random_var ())
-
-let unescape lab =
- assert (lab <> "");
- let lab =
- if lab.[0] = '_' then String.sub lab 1 (String.length lab - 1) else lab
- in
- try
- let i = String.rindex lab '_' in
- if i = 0 then raise Not_found;
- String.sub lab 0 i
- with Not_found ->
- lab
-
-let method_literal meth = str (unescape meth)
-
-let access_object loc e m m_typ f =
- let open Exp in
- with_default_loc loc
- (fun () ->
- let x = random_var () in
- let obj_type = random_var () in
- let obj = annot e Typ.(tconstr "Js.t" [alias (oobject []) obj_type]) in
- let y = random_var () in
- let o = annot (evar y) (Typ.var obj_type) in
- let constr = lam (pvar y) (annot (send o m) m_typ) in
- let_in [Vb.mk (pvar x) obj; Vb.mk (Pat.any ()) constr] (f (evar x))
- )
-
-let method_call loc obj meth args =
- let args = List.map (fun e -> (e, fresh_type ())) args in
- let ret_type = fresh_type () in
- let method_type =
- List.fold_right
- (fun (_, arg_ty) rem_ty -> Typ.arrow "" arg_ty rem_ty)
- args
- (tconstr "Js.meth" [ret_type])
- in
- access_object loc obj meth method_type
- (fun x ->
- let args =
- List.map (fun (e, t) -> apply_ "Js.Unsafe.inject" [annot e t]) args
- in
- annot (apply_ "Js.Unsafe.meth_call" [x; method_literal meth; Exp.array args]) ret_type
- )
-
-
-let mapper _args =
- let open Ast_mapper in
- let rec mk ~js =
- let super = default_mapper in
- let expr this e =
- let loc = e.pexp_loc in
- match e.pexp_desc with
- | Pexp_extension({txt="js";_}, PStr [{pstr_desc=Pstr_eval (e, _);_}]) ->
- let this = mk ~js:true in this.expr this e
-
- | Pexp_field (o, {txt = Lident meth; loc = _}) when js ->
- let o = this.expr this o in
- let prop_type = fresh_type () in
- let meth_type = tconstr "Js.gen_prop" [oobject ["get", prop_type]] in
- access_object loc o meth meth_type
- (fun x -> annot (apply_ "Js.Unsafe.get" [x; method_literal meth]) prop_type)
-
- | Pexp_setfield (o, {txt = Lident meth; loc = _}, e) when js ->
- let o = this.expr this o and e = this.expr this e in
- let prop_type = fresh_type () in
- let meth_type = tconstr "Js.gen_prop" [oobject ["set", Typ.arrow "" prop_type (tconstr "unit" [])]] in
- access_object loc o meth meth_type
- (fun x -> apply_ "Js.Unsafe.set" [x; method_literal meth; annot e prop_type])
-
- | Pexp_apply ({pexp_desc = Pexp_send (o, meth); pexp_loc = loc; _}, args) when js ->
- method_call loc o meth (List.map (this.expr this) (List.map snd args))
-
- | Pexp_send (o, meth) when js ->
- method_call loc o meth []
-
- | _ ->
- super.expr this e
- in
- {super with expr}
- in
- mk ~js:false
-
-let () = Ast_mapper.run_main mapper
+++ /dev/null
-let loc1 = Location.in_file "111"
-let loc2 = Location.in_file "222"
-
-let x = [%expr foobar]
-let pat = [%pat? _ as x]
-
-let e = [%expr fun (x, [%p pat]) -> x + [%e x] + 1]
-let () = Format.printf "%a@." (Printast.expression 0) e
-
-;;[@@metaloc loc2]
-
-let e = [%expr fun (x, [%p pat]) -> x + [%e x] + 1] [@metaloc loc1]
-let () = Format.printf "%a@." (Printast.expression 0) e
-
-let e = [%expr fun (x, [%p pat]) -> x + [%e x] + 1]
-let () = Format.printf "%a@." (Printast.expression 0) e
-
-
-let mytype = [%type: int list]
-let s = [%str type t = A of [%t mytype] | B of string]
-let () = Format.printf "%a@." Printast.implementation s
-
-
-let f = function
- | ([%expr [%e? x] + 1]
- | [%expr 1 + [%e? x]]) as e0 -> [%expr succ [%e x]] [@metaloc e0.pexp_loc]
- | e -> e
+++ /dev/null
-open Asttypes
-open Parsetree
-open Typedtree
-open Longident
-
-let pendings = ref []
-
-let doc ppf = function
- | ({txt="doc";_}, PStr [{pstr_desc=Pstr_eval(e, _); _}]) ->
- begin match e.pexp_desc with
- | Pexp_constant(Const_string (s, _)) ->
- Format.fprintf ppf " --> %s@." s
- | Pexp_apply({pexp_desc=Pexp_ident{txt=Lident "section"}},
- ["", {pexp_desc=Pexp_constant(Const_string (s, _))}]) ->
- Format.fprintf ppf " ==== %s ====@." s
- | _ -> ()
- end
- | _ -> ()
-
-let rec signature path ppf sg =
- List.iter (signature_item path ppf) sg.sig_items
-
-and signature_item path ppf si =
- match si.sig_desc with
- | Tsig_value x ->
- Format.fprintf ppf " val %s: %a@." x.val_name.txt Printtyp.type_expr x.val_desc.ctyp_type;
- List.iter (doc ppf) x.val_attributes
- | Tsig_module x ->
- begin match x.md_type.mty_desc with
- | Tmty_ident (_, {txt=lid}) ->
- Format.fprintf ppf " module %s: %a@." x.md_name.txt Printtyp.longident lid
- | Tmty_signature sg ->
- pendings := `Module (path ^ "." ^ x.md_name.txt, sg) :: !pendings;
- Format.fprintf ppf " module %s: ... (see below)@." x.md_name.txt;
- | _ ->
- Format.fprintf ppf " module %s: ...@." x.md_name.txt;
- end;
- List.iter (doc ppf) x.md_attributes
- | Tsig_type l ->
- List.iter (type_declaration ppf) l
- | Tsig_attribute x ->
- doc ppf x
- | _ ->
- ()
-
-and type_declaration ppf x =
- Format.fprintf ppf " type %s@." x.typ_name.txt;
- List.iter (doc ppf) x.typ_attributes
-
-let component = function
- | `Module (path, sg) ->
- Format.printf "[[[ Interface for %s ]]]@.%a@."
- path (signature path) sg
-
-let () =
- let open Cmt_format in
- for i = 1 to Array.length Sys.argv - 1 do
- let fn = Sys.argv.(i) in
- try
- let {cmt_annots; cmt_modname; _} = read_cmt fn in
- begin match cmt_annots with
- | Interface sg -> component (`Module (cmt_modname, sg))
- | _ -> ()
- end;
- while !pendings <> [] do
- let l = List.rev !pendings in
- pendings := [];
- List.iter component l
- done
- with exn ->
- Format.printf "Cannot read '%s': %s@." fn (Printexc.to_string exn)
- done
+++ /dev/null
-(** Creates an mli from an annotated ml file. *)
-
-open Path
-open Location
-open Longident
-open Misc
-open Parsetree
-open Types
-open! Typedtree
-open Ast_helper
-
-let mli_attr l = Convenience.find_attr "mli" l
-
-let map_flatten f l =
- List.flatten (List.map f l)
-
-let is_abstract = function
- | PStr [{pstr_desc=Pstr_eval({pexp_desc=Pexp_ident{txt=Lident "abstract"}},_)}] -> true
- | _ -> false
-
-let explicit_type_of_expr = function
- | {pexp_desc=Pexp_constraint({pexp_desc=Pexp_ident{txt=Lident id}}, t)} -> [id, t]
- | _ -> []
-
-let explicit_type = function
- | PStr [{pstr_desc=Pstr_eval({pexp_desc=Pexp_tuple el},_)}] -> map_flatten explicit_type_of_expr el
- | PStr [{pstr_desc=Pstr_eval(e,_)}] -> explicit_type_of_expr e
- | _ -> []
-
-let rec structure l : Parsetree.signature =
- map_flatten (structure_item l.str_final_env) l.str_items
-
-and structure_item final_env x : Parsetree.signature =
- match x.str_desc with
- | Tstr_module {mb_name; mb_expr} ->
- begin match module_expr mb_expr with
- | Some mty -> [Sig.module_ (Md.mk mb_name mty)]
- | None -> []
- end
- | Tstr_type l ->
- begin match map_flatten type_declaration l with
- | [] -> []
- | l -> [Sig.type_ l]
- end
- | Tstr_value (_, l) ->
- map_flatten (value_binding final_env) l
- | _ ->
- []
-
-and module_expr x : Parsetree.module_type option =
- match x.mod_desc with
- | Tmod_structure l ->
- (* No explicit signature: use [@@mli] attributes in the sub-structure to define exported components. *)
- begin match structure l with
- | [] -> None
- | l -> Some (Mty.signature l)
- end
- | Tmod_constraint (_, _, Tmodtype_explicit mty, _) ->
- (* Explicit signature: if non-empty, use it for the mli; if empty, drop the sub-module *)
- begin match Untypeast.untype_module_type mty with
- | {pmty_desc=Pmty_signature []} -> None
- | pmty -> Some pmty
- end
- | _ ->
- None
-
-and type_declaration x : Parsetree.type_declaration list =
- match mli_attr x.typ_attributes with
- | None -> []
- | Some attrs ->
- let pdecl = Untypeast.untype_type_declaration x in
- (* If the declaration is marked with [@@mli abstract], make it abstract *)
- let pdecl = if is_abstract attrs then {pdecl with ptype_kind=Ptype_abstract} else pdecl in
- [pdecl]
-
-and value_binding final_env x : Parsetree.signature =
- match mli_attr x.vb_attributes with
- | None -> []
- | Some attrs ->
- match explicit_type attrs with
- | [] ->
- (* No explicit type, use the inferred type for bound identifiers *)
- let ids = let_bound_idents [x] in
- List.map
- (fun id ->
- let ty = typ (Env.find_value (Pident id) final_env).val_type in
- Sig.value (Val.mk (mknoloc (Ident.name id)) ty)
- ) ids
- | l ->
- (* Explicit type given with the syntax [@@mli (x1 : ty1), ..., (xn : tyn)] *)
- List.map (fun (id, ty) -> Sig.value (Val.mk (mknoloc id) ty)) l
-
-and typ x : Parsetree.core_type =
- (* print the inferred type and parse the result again *)
- let t = Printtyp.type_scheme Format.str_formatter x in
- let s = Format.flush_str_formatter t in
- Parse.core_type (Lexing.from_string s)
-
-let mli_of_ml ppf sourcefile =
- Location.input_name := sourcefile;
- Compmisc.init_path false;
- let file = chop_extension_if_any sourcefile in
- let modulename = String.capitalize(Filename.basename file) in
- Env.set_unit_name modulename;
- let inputfile = Pparse.preprocess sourcefile in
- let env = Compmisc.initial_env() in
- let ast = Pparse.file ppf inputfile Parse.implementation Config.ast_impl_magic_number in
- let (str, _coerc) = Typemod.type_implementation sourcefile file modulename env ast in
- let sg = structure str in
- Format.printf "%a@." Pprintast.signature sg
-
-let () =
- mli_of_ml Format.err_formatter Sys.argv.(1)
-
+++ /dev/null
-(*
- A toy -ppx rewriter which illustrates code generation based on type
- declarations. Here, we create builder function from record and sum
- type declarations annotated with attribute [@@builder]: one function
- per record type, one function per constructor of a sum type.
-
- We recognize some special attributes on record fields (or their associated
- type) and on constructor argument types:
-
- - [@label id]: specify a label for the parameter of the builder function
- (for records, it is set automatically from the label name
- but it can be overridden).
-
- - [@opt]: the parameter is optional (this assume that the field/argument
- has an option type).
-
- - [@default expr]: the parameter is optional, with a default value
- (cannot be used with [@opt]).
-*)
-
-module Main : sig end = struct
- open Asttypes
- open! Location
- open Parsetree
- open Ast_helper
- open Ast_helper.Convenience
-
- let fatal loc s =
- Location.print_error Format.err_formatter loc;
- prerr_endline s;
- exit 2
-
- let param named name loc attrs =
- let default = find_attr_expr "default" attrs in
- let opt = has_attr "opt" attrs in
- let label =
- match find_attr_expr "label" attrs with
- | None -> if named then name else ""
- | Some e ->
- match get_lid e with
- | Some s -> s
- | None -> fatal e.pexp_loc "'label' attribute must be a string literal"
- in
- let label =
- if default <> None || opt then
- if label = "" then fatal loc "Optional arguments must be named" else "?" ^ label
- else label
- in
- if default <> None && opt then fatal loc "Cannot have both 'opt' and 'default' attributes";
- lam ~label ?default (pvar name), (name, evar name)
-
- let gen_builder tdecl =
- if has_attr "builder" tdecl.ptype_attributes then
- match tdecl.ptype_kind with
- | Ptype_record fields ->
- let field pld =
- param true pld.pld_name.txt pld.pld_loc (pld.pld_attributes @ pld.pld_type.ptyp_attributes)
- in
- let fields = List.map field fields in
- let body = lam (punit()) (record (List.map snd fields)) in
- let f = List.fold_right (fun (f, _) k -> f k) fields body in
- let s = Str.value Nonrecursive [Vb.mk (pvar tdecl.ptype_name.txt) f] in
- [s]
- | Ptype_variant constrs ->
- let constr {pcd_name={txt=name;_}; pcd_args=args; _} =
- let arg i ty = param false (Printf.sprintf "x%i" i) ty.ptyp_loc ty.ptyp_attributes in
- let args = List.mapi arg args in
- let body = lam (punit()) (constr name (List.map (fun (_, (_, e)) -> e) args)) in
- let f = List.fold_right (fun (f, _) k -> f k) args body in
- let s = Str.value Nonrecursive [Vb.mk (pvar (tdecl.ptype_name.txt ^ "_" ^ name)) f] in
- s
- in
- List.map constr constrs
- | _ -> []
- else
- []
-
- let gen_builder tdecl =
- with_default_loc tdecl.ptype_loc (fun () -> gen_builder tdecl)
-
- let builder _args =
- let open Ast_mapper in
- let super = default_mapper in
- {super
- with
- structure =
- (fun this l ->
- List.flatten
- (List.map
- (function
- | {pstr_desc = Pstr_type tdecls; _} as i ->
- i :: (List.flatten (List.map gen_builder tdecls))
- | i -> [this.structure_item this i]
- ) l
- )
- )
- }
-
- let () = Ast_mapper.run_main builder
-end
+++ /dev/null
-(*
- Example : List.filter [%matches ? 'a' .. 'z' ] text
- Output : List.filter (function 'a' .. 'z' -> true | _ -> false) text
-*)
-
-open Asttypes
-open Parsetree
-open Ast_helper
-
-let mapper _args =
- let open Ast_mapper in
- let super = default_mapper in
- {super with
- expr =
- (fun this e ->
- match e.pexp_desc with
- | Pexp_extension({txt="matches";_}, PPat (p, guard)) ->
- let p = this.pat this p in
- let guard = Ast_mapper.map_opt (this.expr this) guard in
- Exp.function_ ~loc:e.pexp_loc
- [
- Exp.case p ?guard (Convenience.constr "true" []);
- Exp.case (Pat.any ()) (Convenience.constr "false" []);
- ]
- | _ -> super.expr this e
- )
- }
-
-let () = Ast_mapper.run_main mapper
+++ /dev/null
-type t =
- {
- x: int;
- y [@label foo]: int;
- z [@default 3]: int;
- } [@@builder]
-
-and s =
- {
- a: string;
- b [@opt]: int option;
- c: int [@default 2];
- } [@@builder]
-
-and sum =
- | A of int
- | B of string * (string [@label str])
- | C of (int [@label i] [@default 0]) * (string [@label s] [@default ""])
- [@@builder]
+++ /dev/null
-module type S = [%copy_typedef]
-
-module type T = sig
- type t
-
- module type M = [%copy_typedef]
-end
-
-module M = struct
- type t = [%copy_typedef]
-end
-
-type t = [%copy_typedef]
-
-let _x = M.A
-let _y : t = [1; 2]
-
-
-type _loc = [%copy_typedef "../../parsing/location.mli" t]
+++ /dev/null
-module type S = sig
- type t
- val x: int
-end
-
-module type T = sig
- type t
-
- module type M = sig
- type t = A | B of t
- end
-end
-
-module M : sig
- type t =
- | A
- | B of string
-end
-
-type t = int list
+++ /dev/null
-[%%eval.load "unix.cma"]
-
-[%%eval.start both]
-(* This type definition will be evaluated at compile time,
- but it will be kept in the compiled unit as well. *)
-type t = A | B of string
-[%%eval.stop]
-
-[%%eval.start]
-(* This is going to be executed at compile time only. *)
-let () = print_endline "Now compiling..."
-[%%eval.stop]
-
-let () =
- begin match [%eval B "x"] with
- | A -> print_endline "A"
- | B s -> Printf.printf "B %S\n%!" s
- end;
- Printf.printf "Home dir at compile time = %s\n" [%eval Sys.getenv "HOME"];
- Printf.printf "Word-size = %i\n" [%eval Sys.word_size];
- Array.iter (Printf.printf "%s;") [%eval Sys.readdir "."];
- print_endline "";
- [%eval print_endline "COUCOU"]
-
-let () =
- let tm = [%eval Unix.(localtime (gettimeofday ()))] in
- Printf.printf "This program was compiled in %i\n%!" (1900 + tm.Unix.tm_year)
-
-let () =
- let debug =
- [%eval try Some (Sys.getenv "DEBUG") with Not_found -> None]
- in
- match debug with
- | Some x -> Printf.printf "DEBUG %s\n%!" x
- | None -> Printf.printf "NODEBUG\n%!"
-
-
+++ /dev/null
-type t =
- | A
- | DBG [@IFDEF DEBUG] of string
- | B
-
-[%%IFDEF DEBUG]
-let debug s = prerr_endline ([%GETENV DEBUG] ^ ":" ^ s)
-let x = DBG "xxx"
-[%%ELSE]
-let debug _ = ()
-let x = A
-[%%END]
-
-let f = function
- | A -> "A"
- | DBG s when [%IFDEF DEBUG] -> "DEBUG:" ^ s
- | B -> "B"
-
-let () = debug "ABC"
-
-let () =
- Printf.printf "compiled by user %s in directory %s\n%!"
- [%GETENV USER]
- [%GETENV PWD]
-
+++ /dev/null
-module Js = struct
- type +'a t
- type +'a gen_prop
- type +'a meth
- module Unsafe = struct
- type any
- let get (_o : 'a t) (_meth : string) = assert false
- let set (_o : 'a t) (_meth : string) (_v : 'b) = ()
- let meth_call (_ : 'a) (_ : string) (_ : any array) : 'b = assert false
- let inject _ : any = assert false
- end
-end
-
-let foo1 o =
- if [%js o.bar] then [%js o.foo1.foo2] else [%js o.foo2]
-
-let foo2 o =
- [%js o.x <- o.x + 1]
-
-
-let foo3 o a =
- [%js o#x] + [%js o#y 1 a]
+++ /dev/null
-let l = List.filter [%matches ? 'a'..'z'] ['a';'A';'X';'x']
-
-let f = [%matches ? Some i when i >= 0]
+++ /dev/null
-type t = A | B
- [@@mli]
-
-and s = C | D
- [@@mli abstract]
-
-
-module X = struct
- type t = X | Y
- [@@mli]
- and s
-
- let id x = x
- [@@mli]
-end
-
-module Y : sig type t type s end = struct
- type t = X | Y
- type s = A | B
-end
-
-let f x y = x + y
- [@@mli]
-and g a b = (a, b)
- [@@mli]
-and h a b = (a, b)
- [@@mli (h : int -> int -> int * int)]
-
-let (x, y, z) = (1, 2, 3)
- [@@mli (x : int), (y : int)]
+++ /dev/null
-[@@doc section "First section"]
-
-module M : sig
- [@@doc section "Public definitions"]
-
- type t =
- | A
- | B
-
- [@@doc section "Internal definitions"]
-
- val zero: int
- [@@doc "A very important integer."]
-end
- [@@doc "This is an internal module."]
-
-val incr: int -> int
- [@@doc "This function returns the next integer."]
-
-[@@doc section "Second section"]
-
-val decr: int -> int
- [@@doc "This function returns the previous integer."]
-
-val is_a: M.t -> bool
- [@@doc "This function checks whether its argument is the A constructor."]
-
-module X: Hashtbl.HashedType
- [@@doc "An internal module"]
+++ /dev/null
-(* This tool reports values exported by .mli files but never used in any other module.
- It assumes that .mli files are compiled with -keep-locs and .ml files with -bin-annot.
- This can be enforced by setting:
-
- OCAMLPARAM=bin-annot=1,keep-locs=1,_
-*)
-
-
-open Types
-open Typedtree
-
-let vds = ref [] (* all exported value declarations *)
-let references = Hashtbl.create 256 (* all value references *)
-
-let unit fn =
- Filename.chop_extension (Filename.basename fn)
-
-let rec collect_export fn = function
- | Sig_value (_, {Types.val_loc; _}) when not val_loc.Location.loc_ghost ->
- (* a .cmi file can contain locations from other files.
- For instance:
- module M : Set.S with type elt = int
- will create value definitions whole locations is in set.mli
- *)
- if unit fn = unit val_loc.Location.loc_start.Lexing.pos_fname then
- vds := val_loc :: !vds
- | Sig_module (_, {Types.md_type=Mty_signature sg; _}, _) -> List.iter (collect_export fn) sg
- | _ -> ()
-
-let collect_references = object
- inherit Tast_iter.iter as super
- method! expression = function
- | {exp_desc = Texp_ident (_, _, {Types.val_loc; _}); exp_loc} -> Hashtbl.add references val_loc exp_loc
- | e -> super # expression e
-end
-
-let rec load_file fn =
- if Filename.check_suffix fn ".cmi"
- && Sys.file_exists (Filename.chop_suffix fn ".cmi" ^ ".mli") then
- (* only consider module with an explicit interface *)
- let open Cmi_format in
-(* Printf.eprintf "Scanning %s\n%!" fn; *)
- List.iter (collect_export fn) (read_cmi fn).cmi_sign
- else if Filename.check_suffix fn ".cmt" then
- let open Cmt_format in
-(* Printf.eprintf "Scanning %s\n%!" fn; *)
- match read fn with
- | (_, Some {cmt_annots = Implementation x; _}) -> collect_references # structure x
- | _ -> () (* todo: support partial_implementation? *)
- else if (try Sys.is_directory fn with _ -> false) then
- Array.iter (fun s -> load_file (Filename.concat fn s)) (Sys.readdir fn)
-
-let report loc =
- if not (Hashtbl.mem references loc) then
- Format.printf "%a: unused exported value@." Location.print_loc loc
-
-let () =
- try
- for i = 1 to Array.length Sys.argv - 1 do load_file Sys.argv.(i) done;
- List.iter report !vds
- with exn ->
- Location.report_exception Format.err_formatter exn;
- exit 2
+++ /dev/null
-*.out
-*.out2
+++ /dev/null
-Index: byterun/intern.c
-===================================================================
---- byterun/intern.c (revision 11929)
-+++ byterun/intern.c (working copy)
-@@ -27,6 +27,7 @@
- #include "memory.h"
- #include "mlvalues.h"
- #include "misc.h"
-+#include "obj.h"
- #include "reverse.h"
-
- static unsigned char * intern_src;
-@@ -139,6 +140,14 @@
- dest = (value *) (intern_dest + 1);
- *intern_dest = Make_header(size, tag, intern_color);
- intern_dest += 1 + size;
-+ /* For objects, we need to freshen the oid */
-+ if (tag == Object_tag) {
-+ intern_rec(dest++);
-+ intern_rec(dest++);
-+ caml_set_oid((value)(dest-2));
-+ size -= 2;
-+ if (size == 0) return;
-+ }
- for(/*nothing*/; size > 1; size--, dest++)
- intern_rec(dest);
- goto tailcall;
-Index: byterun/obj.c
-===================================================================
---- byterun/obj.c (revision 11929)
-+++ byterun/obj.c (working copy)
-@@ -25,6 +25,7 @@
- #include "minor_gc.h"
- #include "misc.h"
- #include "mlvalues.h"
-+#include "obj.h"
- #include "prims.h"
-
- CAMLprim value caml_static_alloc(value size)
-@@ -212,6 +213,16 @@
- return (tag == Field(meths,li) ? Field (meths, li-1) : 0);
- }
-
-+/* Generate ids on the C side, to avoid races */
-+
-+CAMLprim value caml_set_oid (value obj)
-+{
-+ static value last_oid = 1;
-+ Field(obj,1) = last_oid;
-+ last_oid += 2;
-+ return obj;
-+}
-+
- /* these two functions might be useful to an hypothetical JIT */
-
- #ifdef CAML_JIT
-Index: byterun/obj.h
-===================================================================
---- byterun/obj.h (revision 0)
-+++ byterun/obj.h (revision 0)
-@@ -0,0 +1,28 @@
-+/***********************************************************************/
-+/* */
-+/* OCaml */
-+/* */
-+/* Jacques Garrigue, projet Cristal, INRIA Rocquencourt */
-+/* */
-+/* Copyright 1996 Institut National de Recherche en Informatique et */
-+/* en Automatique. All rights reserved. This file is distributed */
-+/* under the terms of the GNU Library General Public License, with */
-+/* the special exception on linking described in file ../LICENSE. */
-+/* */
-+/***********************************************************************/
-+
-+/* $Id$ */
-+
-+/* Primitives for the Obj and CamlinternalOO modules */
-+
-+#ifndef CAML_OBJ_H
-+#define CAML_OBJ_H
-+
-+#include "misc.h"
-+#include "mlvalues.h"
-+
-+/* Set the OID of an object to a fresh value */
-+/* returns the same object as result */
-+value caml_set_oid (value obj);
-+
-+#endif /* CAML_OBJ_H */
-Index: stdlib/camlinternalOO.ml
-===================================================================
---- stdlib/camlinternalOO.ml (revision 11929)
-+++ stdlib/camlinternalOO.ml (working copy)
-@@ -15,23 +15,15 @@
-
- open Obj
-
--(**** Object representation ****)
-+(**** OID handling ****)
-
--let last_id = ref 0
--let new_id () =
-- let id = !last_id in incr last_id; id
-+external set_oid : t -> t = "caml_set_oid" "noalloc"
-
--let set_id o id =
-- let id0 = !id in
-- Array.unsafe_set (Obj.magic o : int array) 1 id0;
-- id := id0 + 1
--
- (**** Object copy ****)
-
- let copy o =
-- let o = (Obj.obj (Obj.dup (Obj.repr o))) in
-- set_id o last_id;
-- o
-+ let o = Obj.dup (Obj.repr o) in
-+ Obj.obj (set_oid o)
-
- (**** Compression options ****)
- (* Parameters *)
-@@ -355,8 +347,7 @@
- let obj = Obj.new_block Obj.object_tag table.size in
- (* XXX Appel de [caml_modify] *)
- Obj.set_field obj 0 (Obj.repr table.methods);
-- set_id obj last_id;
-- (Obj.obj obj)
-+ Obj.obj (set_oid obj)
-
- let create_object_opt obj_0 table =
- if (Obj.magic obj_0 : bool) then obj_0 else begin
-@@ -364,8 +355,7 @@
- let obj = Obj.new_block Obj.object_tag table.size in
- (* XXX Appel de [caml_modify] *)
- Obj.set_field obj 0 (Obj.repr table.methods);
-- set_id obj last_id;
-- (Obj.obj obj)
-+ Obj.obj (set_oid obj)
- end
-
- let rec iter_f obj =
+++ /dev/null
-Index: typing/ctype.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v
-retrieving revision 1.201
-diff -u -r1.201 ctype.ml
---- typing/ctype.ml 5 Apr 2006 02:28:13 -0000 1.201
-+++ typing/ctype.ml 17 May 2006 23:48:22 -0000
-@@ -490,6 +490,31 @@
- unmark_class_signature sign;
- Some reason
-
-+(* Variant for checking principality *)
-+
-+let rec free_nodes_rec ty =
-+ let ty = repr ty in
-+ if ty.level >= lowest_level then begin
-+ if ty.level <= !current_level then raise Exit;
-+ ty.level <- pivot_level - ty.level;
-+ begin match ty.desc with
-+ Tvar ->
-+ raise Exit
-+ | Tobject (ty, _) ->
-+ free_nodes_rec ty
-+ | Tfield (_, _, ty1, ty2) ->
-+ free_nodes_rec ty1; free_nodes_rec ty2
-+ | Tvariant row ->
-+ let row = row_repr row in
-+ iter_row free_nodes_rec {row with row_bound = []};
-+ if not (static_row row) then free_nodes_rec row.row_more
-+ | _ ->
-+ iter_type_expr free_nodes_rec ty
-+ end;
-+ end
-+
-+let has_free_nodes ty =
-+ try free_nodes_rec ty; false with Exit -> true
-
- (**********************)
- (* Type duplication *)
-Index: typing/ctype.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.mli,v
-retrieving revision 1.54
-diff -u -r1.54 ctype.mli
---- typing/ctype.mli 5 Apr 2006 02:28:13 -0000 1.54
-+++ typing/ctype.mli 17 May 2006 23:48:22 -0000
-@@ -228,6 +228,9 @@
- val closed_class:
- type_expr list -> class_signature -> closed_class_failure option
- (* Check whether all type variables are bound *)
-+val has_free_nodes: type_expr -> bool
-+ (* Check whether there are free type variables, or nodes with
-+ level lower or equal to !current_level *)
-
- val unalias: type_expr -> type_expr
- val signature_of_class_type: class_type -> class_signature
-Index: typing/typecore.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v
-retrieving revision 1.181
-diff -u -r1.181 typecore.ml
---- typing/typecore.ml 16 Apr 2006 23:28:22 -0000 1.181
-+++ typing/typecore.ml 17 May 2006 23:48:22 -0000
-@@ -1183,12 +1183,29 @@
- let (ty', force) =
- Typetexp.transl_simple_type_delayed env sty'
- in
-+ if !Clflags.principal then begin_def ();
- let arg = type_exp env sarg in
-+ let has_fv =
-+ if !Clflags.principal then begin
-+ end_def ();
-+ let b = has_free_nodes arg.exp_type in
-+ Ctype.unify env arg.exp_type (newvar ());
-+ b
-+ end else
-+ free_variables arg.exp_type <> []
-+ in
- begin match arg.exp_desc, !self_coercion, (repr ty').desc with
- Texp_ident(_, {val_kind=Val_self _}), (path,r) :: _,
- Tconstr(path',_,_) when Path.same path path' ->
- r := sexp.pexp_loc :: !r;
- force ()
-+ | _ when not has_fv ->
-+ begin try
-+ let force' = subtype env arg.exp_type ty' in
-+ force (); force' ()
-+ with Subtype (tr1, tr2) ->
-+ raise(Error(sexp.pexp_loc, Not_subtype(tr1, tr2)))
-+ end
- | _ ->
- let ty, b = enlarge_type env ty' in
- force ();
+++ /dev/null
-let rec long_lines name n ic =
- let l = input_line ic in
- if String.length l > 80 then Printf.printf "%s: %d\n%!" name n;
- long_lines name (n+1) ic
-
-let process_file name =
- try
- let ic = open_in name in
- try long_lines name 1 ic
- with End_of_file -> close_in ic
- with _ ->()
-
-let () =
- for i = 1 to Array.length Sys.argv - 1 do
- process_file Sys.argv.(i)
- done
+++ /dev/null
-parsing typing bytecomp driver toplevel
+++ /dev/null
-bytecomp byterun driver parsing stdlib tools toplevel typing utils
+++ /dev/null
-(* cvs update -r fixedtypes parsing typing *)
-
-(* recursive types *)
-class c = object (self) method m = 1 method s = self end
-module type S = sig type t = private #c end;;
-
-module M : S = struct type t = c end
-module type S' = S with type t = c;;
-
-class d = object inherit c method n = 2 end
-module type S2 = S with type t = private #d;;
-module M2 : S = struct type t = d end;;
-module M3 : S = struct type t = private #d end;;
-
-module T1 = struct
- type ('a,'b) a = [`A of 'a | `B of 'b]
- type ('a,'b) b = [`Z | ('a,'b) a]
-end
-module type T2 = sig
- type a and b
- val evala : a -> int
- val evalb : b -> int
-end
-module type T3 = sig
- type a0 = private [> (a0,b0) T1.a]
- and b0 = private [> (a0,b0) T1.b]
-end
-module type T4 = sig
- include T3
- include T2 with type a = a0 and type b = b0
-end
-module F(X:T4) = struct
- type a = X.a and b = X.b
- let a = X.evala (`B `Z)
- let b = X.evalb (`A(`B `Z))
- let a2b (x : a) : b = `A x
- let b2a (x : b) : a = `B x
-end
-module M4 = struct
- type a = [`A of a | `B of b | `ZA]
- and b = [`A of a | `B of b | `Z]
- type a0 = a
- type b0 = b
- let rec eval0 = function
- `A a -> evala a
- | `B b -> evalb b
- and evala : a -> int = function
- #T1.a as x -> 1 + eval0 x
- | `ZA -> 3
- and evalb : b -> int = function
- #T1.a as x -> 1 + eval0 x
- | `Z -> 7
-end
-module M5 = F(M4)
-
-module M6 : sig
- class ci : int ->
- object
- val x : int
- method x : int
- method move : int -> unit
- end
- type c = private #ci
- val create : int -> c
-end = struct
- class ci x = object
- val mutable x : int = x
- method x = x
- method move d = x <- x+d
- end
- type c = ci
- let create = new ci
-end
-let f (x : M6.c) = x#move 3; x#x;;
-
-module M : sig type t = private [> `A of bool] end =
- struct type t = [`A of int] end
+++ /dev/null
-Index: typing/env.ml
-===================================================================
---- typing/env.ml (revision 11214)
-+++ typing/env.ml (working copy)
-@@ -20,6 +20,7 @@
- open Longident
- open Path
- open Types
-+open Btype
-
-
- type error =
-@@ -56,7 +57,7 @@
- cltypes: (Path.t * cltype_declaration) Ident.tbl;
- summary: summary;
- local_constraints: bool;
-- level_map: (int * int) list;
-+ gadt_instances: (int * TypeSet.t ref) list;
- }
-
- and module_components = module_components_repr Lazy.t
-@@ -96,7 +97,7 @@
- modules = Ident.empty; modtypes = Ident.empty;
- components = Ident.empty; classes = Ident.empty;
- cltypes = Ident.empty;
-- summary = Env_empty; local_constraints = false; level_map = [] }
-+ summary = Env_empty; local_constraints = false; gadt_instances = [] }
-
- let diff_keys is_local tbl1 tbl2 =
- let keys2 = Ident.keys tbl2 in
-@@ -286,13 +287,14 @@
- (* the level is changed when updating newtype definitions *)
- if !Clflags.principal then begin
- match level, decl.type_newtype_level with
-- Some level, Some def_level when level < def_level -> raise Not_found
-+ Some level, Some (_, exp_level) when level < exp_level -> raise Not_found
- | _ -> ()
- end;
- match decl.type_manifest with
- | Some body when decl.type_private = Public
- || decl.type_kind <> Type_abstract
-- || Btype.has_constr_row body -> (decl.type_params, body)
-+ || Btype.has_constr_row body ->
-+ (decl.type_params, body, may_map snd decl.type_newtype_level)
- (* The manifest type of Private abstract data types without
- private row are still considered unknown to the type system.
- Hence, this case is caught by the following clause that also handles
-@@ -308,7 +310,7 @@
- match decl.type_manifest with
- (* The manifest type of Private abstract data types can still get
- an approximation using their manifest type. *)
-- | Some body -> (decl.type_params, body)
-+ | Some body -> (decl.type_params, body, may_map snd decl.type_newtype_level)
- | _ -> raise Not_found
-
- let find_modtype_expansion path env =
-@@ -453,32 +455,42 @@
- and lookup_cltype =
- lookup (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes)
-
--(* Level handling *)
-+(* GADT instance tracking *)
-
--(* The level map is a list of pairs describing separate segments (lv,lv'),
-- lv < lv', organized in decreasing order.
-- The definition level is obtained by mapping a level in a segment to the
-- high limit of this segment.
-- The definition level of a newtype should be greater or equal to
-- the highest level of the newtypes in its manifest type.
-- *)
-+let add_gadt_instance_level lv env =
-+ {env with
-+ gadt_instances = (lv, ref TypeSet.empty) :: env.gadt_instances}
-
--let rec map_level lv = function
-- | [] -> lv
-- | (lv1, lv2) :: rem ->
-- if lv > lv2 then lv else
-- if lv >= lv1 then lv2 else map_level lv rem
-+let is_Tlink = function {desc = Tlink _} -> true | _ -> false
-
--let map_newtype_level env lv = map_level lv env.level_map
-+let gadt_instance_level env t =
-+ let rec find_instance = function
-+ [] -> None
-+ | (lv, r) :: rem ->
-+ if TypeSet.exists is_Tlink !r then
-+ r := TypeSet.fold (fun ty -> TypeSet.add (repr ty)) !r TypeSet.empty;
-+ if TypeSet.mem t !r then Some lv else find_instance rem
-+ in find_instance env.gadt_instances
-
--(* precondition: lv < lv' *)
--let rec add_level lv lv' = function
-- | [] -> [lv, lv']
-- | (lv1, lv2) :: rem as l ->
-- if lv2 < lv then (lv, lv') :: l else
-- if lv' < lv1 then (lv1, lv2) :: add_level lv lv' rem
-- else add_level (max lv lv1) (min lv' lv2) rem
-+let add_gadt_instances env lv tl =
-+ let r =
-+ try List.assoc lv env.gadt_instances with Not_found -> assert false in
-+ r := List.fold_right TypeSet.add tl !r
-
-+(* Only use this after expand_head! *)
-+let add_gadt_instance_chain env lv t =
-+ let r =
-+ try List.assoc lv env.gadt_instances with Not_found -> assert false in
-+ let rec add_instance t =
-+ let t = repr t in
-+ if not (TypeSet.mem t !r) then begin
-+ r := TypeSet.add t !r;
-+ match t.desc with
-+ Tconstr (p, _, memo) ->
-+ may add_instance (find_expans Private p !memo)
-+ | _ -> ()
-+ end
-+ in add_instance t
-
- (* Expand manifest module type names at the top of the given module type *)
-
-@@ -497,7 +509,7 @@
- let constructors_of_type ty_path decl =
- let handle_variants cstrs =
- Datarepr.constructor_descrs
-- (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
-+ (newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
- cstrs decl.type_private
- in
- match decl.type_kind with
-@@ -510,7 +522,7 @@
- match decl.type_kind with
- Type_record(labels, rep) ->
- Datarepr.label_descrs
-- (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
-+ (newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
- labels rep decl.type_private
- | Type_variant _ | Type_abstract -> []
-
-@@ -773,14 +785,13 @@
- and add_cltype id ty env =
- store_cltype id (Pident id) ty env
-
--let add_local_constraint id info mlv env =
-+let add_local_constraint id info elv env =
- match info with
-- {type_manifest = Some ty; type_newtype_level = Some lv} ->
-- (* use the newtype level for this definition, lv is the old one *)
-- let env = add_type id {info with type_newtype_level = Some mlv} env in
-- let level_map =
-- if lv < mlv then add_level lv mlv env.level_map else env.level_map in
-- { env with local_constraints = true; level_map = level_map }
-+ {type_manifest = Some ty; type_newtype_level = Some (lv, _)} ->
-+ (* elv is the expansion level, lv is the definition level *)
-+ let env =
-+ add_type id {info with type_newtype_level = Some (lv, elv)} env in
-+ { env with local_constraints = true }
- | _ -> assert false
-
- (* Insertion of bindings by name *)
-Index: typing/typecore.ml
-===================================================================
---- typing/typecore.ml (revision 11214)
-+++ typing/typecore.ml (working copy)
-@@ -1989,6 +1989,7 @@
- end
- | Pexp_newtype(name, sbody) ->
- (* Create a fake abstract type declaration for name. *)
-+ let level = get_current_level () in
- let decl = {
- type_params = [];
- type_arity = 0;
-@@ -1996,7 +1997,7 @@
- type_private = Public;
- type_manifest = None;
- type_variance = [];
-- type_newtype_level = Some (get_current_level ());
-+ type_newtype_level = Some (level, level);
- }
- in
- let ty = newvar () in
-@@ -2421,6 +2422,7 @@
- begin_def ();
- Ident.set_current_time (get_current_level ());
- let lev = Ident.current_time () in
-+ let env = Env.add_gadt_instance_level lev env in
- Ctype.init_def (lev+1000);
- if !Clflags.principal then begin_def (); (* propagation of the argument *)
- let ty_arg' = newvar () in
-Index: typing/typedecl.ml
-===================================================================
---- typing/typedecl.ml (revision 11214)
-+++ typing/typedecl.ml (working copy)
-@@ -404,7 +404,7 @@
- else if to_check path' && not (List.mem path' prev_exp) then begin
- try
- (* Attempt expansion *)
-- let (params0, body0) = Env.find_type_expansion path' env in
-+ let (params0, body0, _) = Env.find_type_expansion path' env in
- let (params, body) =
- Ctype.instance_parameterized_type params0 body0 in
- begin
-Index: typing/types.mli
-===================================================================
---- typing/types.mli (revision 11214)
-+++ typing/types.mli (working copy)
-@@ -144,9 +144,9 @@
- type_manifest: type_expr option;
- type_variance: (bool * bool * bool) list;
- (* covariant, contravariant, weakly contravariant *)
-- type_newtype_level: int option }
-+ type_newtype_level: (int * int) option }
-+ (* definition level * expansion level *)
-
--
- and type_kind =
- Type_abstract
- | Type_record of
-Index: typing/ctype.ml
-===================================================================
---- typing/ctype.ml (revision 11214)
-+++ typing/ctype.ml (working copy)
-@@ -470,7 +470,7 @@
- free_variables := (ty, real) :: !free_variables
- | Tconstr (path, tl, _), Some env ->
- begin try
-- let (_, body) = Env.find_type_expansion path env in
-+ let (_, body, _) = Env.find_type_expansion path env in
- if (repr body).level <> generic_level then
- free_variables := (ty, real) :: !free_variables
- with Not_found -> ()
-@@ -687,7 +687,7 @@
- try
- match (Env.find_type p env).type_newtype_level with
- | None -> Path.binding_time p
-- | Some x -> x
-+ | Some (x, _) -> x
- with
- | _ ->
- (* no newtypes in predef *)
-@@ -696,9 +696,13 @@
- let rec update_level env level ty =
- let ty = repr ty in
- if ty.level > level then begin
-+ if !Clflags.principal && Env.has_local_constraints env then begin
-+ match Env.gadt_instance_level env ty with
-+ Some lv -> if level < lv then raise (Unify [(ty, newvar2 level)])
-+ | None -> ()
-+ end;
- match ty.desc with
-- Tconstr(p, tl, abbrev)
-- when level < Env.map_newtype_level env (get_level env p) ->
-+ Tconstr(p, tl, abbrev) when level < get_level env p ->
- (* Try first to replace an abbreviation by its expansion. *)
- begin try
- (* if is_newtype env p then raise Cannot_expand; *)
-@@ -1025,7 +1029,7 @@
- | Some (env, newtype_lev) ->
- let existentials = List.map copy cstr.cstr_existentials in
- let process existential =
-- let decl = new_declaration (Some newtype_lev) None in
-+ let decl = new_declaration (Some (newtype_lev, newtype_lev)) None in
- let (id, new_env) =
- Env.enter_type (get_new_abstract_name ()) decl !env in
- env := new_env;
-@@ -1271,7 +1275,7 @@
- end;
- ty
- | None ->
-- let (params, body) =
-+ let (params, body, lv) =
- try find_type_expansion level path env with Not_found ->
- raise Cannot_expand
- in
-@@ -1284,6 +1288,15 @@
- ty.desc <- Tvariant { row with row_name = Some (path, args) }
- | _ -> ()
- end;
-+ (* For gadts, remember type as non exportable *)
-+ if !Clflags.principal then begin
-+ match lv with
-+ Some lv -> Env.add_gadt_instances env lv [ty; ty']
-+ | None ->
-+ match Env.gadt_instance_level env ty with
-+ Some lv -> Env.add_gadt_instances env lv [ty']
-+ | None -> ()
-+ end;
- ty'
- end
- | _ ->
-@@ -1306,15 +1319,7 @@
- let try_expand_once env ty =
- let ty = repr ty in
- match ty.desc with
-- Tconstr (p, _, _) ->
-- let ty' = repr (expand_abbrev env ty) in
-- if !Clflags.principal then begin
-- match (Env.find_type p env).type_newtype_level with
-- Some lv when ty.level < Env.map_newtype_level env lv ->
-- link_type ty ty'
-- | _ -> ()
-- end;
-- ty'
-+ Tconstr (p, _, _) -> repr (expand_abbrev env ty)
- | _ -> raise Cannot_expand
-
- let _ = forward_try_expand_once := try_expand_once
-@@ -1324,11 +1329,16 @@
- May raise Unify, if a recursion was hidden in the type. *)
- let rec try_expand_head env ty =
- let ty' = try_expand_once env ty in
-- begin try
-- try_expand_head env ty'
-- with Cannot_expand ->
-- ty'
-- end
-+ let ty'' =
-+ try try_expand_head env ty'
-+ with Cannot_expand -> ty'
-+ in
-+ if !Clflags.principal then begin
-+ match Env.gadt_instance_level env ty'' with
-+ None -> ()
-+ | Some lv -> Env.add_gadt_instance_chain env lv ty
-+ end;
-+ ty''
-
- (* Expand once the head of a type *)
- let expand_head_once env ty =
-@@ -1405,7 +1415,7 @@
- *)
- let generic_abbrev env path =
- try
-- let (_, body) = Env.find_type_expansion path env in
-+ let (_, body, _) = Env.find_type_expansion path env in
- (repr body).level = generic_level
- with
- Not_found ->
-@@ -1742,7 +1752,7 @@
- let reify env t =
- let newtype_level = get_newtype_level () in
- let create_fresh_constr lev row =
-- let decl = new_declaration (Some (newtype_level)) None in
-+ let decl = new_declaration (Some (newtype_level, newtype_level)) None in
- let name =
- let name = get_new_abstract_name () in
- if row then name ^ "#row" else name
-@@ -2065,7 +2075,7 @@
- update_level !env t1.level t2;
- link_type t1 t2
- | (Tconstr (p1, [], a1), Tconstr (p2, [], a2))
-- when Path.same p1 p2 && actual_mode !env = Old
-+ when Path.same p1 p2 (* && actual_mode !env = Old *)
- (* This optimization assumes that t1 does not expand to t2
- (and conversely), so we fall back to the general case
- when any of the types has a cached expansion. *)
-@@ -2091,6 +2101,15 @@
- if unify_eq !env t1' t2' then () else
-
- let t1 = repr t1 and t2 = repr t2 in
-+ if !Clflags.principal then begin
-+ match Env.gadt_instance_level !env t1',Env.gadt_instance_level !env t2' with
-+ Some lv1, Some lv2 ->
-+ if lv1 > lv2 then Env.add_gadt_instance_chain !env lv1 t2 else
-+ if lv2 > lv2 then Env.add_gadt_instance_chain !env lv2 t1
-+ | Some lv1, None -> Env.add_gadt_instance_chain !env lv1 t2
-+ | None, Some lv2 -> Env.add_gadt_instance_chain !env lv2 t1
-+ | None, None -> ()
-+ end;
- if unify_eq !env t1 t1' || not (unify_eq !env t2 t2') then
- unify3 env t1 t1' t2 t2'
- else
-Index: typing/env.mli
-===================================================================
---- typing/env.mli (revision 11214)
-+++ typing/env.mli (working copy)
-@@ -33,14 +33,19 @@
- val find_cltype: Path.t -> t -> cltype_declaration
-
- val find_type_expansion:
-- ?use_local:bool -> ?level:int -> Path.t -> t -> type_expr list * type_expr
--val find_type_expansion_opt: Path.t -> t -> type_expr list * type_expr
-+ ?use_local:bool -> ?level:int -> Path.t -> t ->
-+ type_expr list * type_expr * int option
-+val find_type_expansion_opt:
-+ Path.t -> t -> type_expr list * type_expr * int option
- (* Find the manifest type information associated to a type for the sake
- of the compiler's type-based optimisations. *)
- val find_modtype_expansion: Path.t -> t -> Types.module_type
-
- val has_local_constraints: t -> bool
--val map_newtype_level: t -> int -> int
-+val add_gadt_instance_level: int -> t -> t
-+val gadt_instance_level: t -> type_expr -> int option
-+val add_gadt_instances: t -> int -> type_expr list -> unit
-+val add_gadt_instance_chain: t -> int -> type_expr -> unit
-
- (* Lookup by long identifiers *)
-
-Index: typing/types.ml
-===================================================================
---- typing/types.ml (revision 11214)
-+++ typing/types.ml (working copy)
-@@ -146,8 +146,8 @@
- type_private: private_flag;
- type_manifest: type_expr option;
- type_variance: (bool * bool * bool) list;
-- type_newtype_level: int option }
- (* covariant, contravariant, weakly contravariant *)
-+ type_newtype_level: (int * int) option }
-
- and type_kind =
- Type_abstract
-Index: testsuite/tests/typing-gadts/test.ml
-===================================================================
---- testsuite/tests/typing-gadts/test.ml (revision 11214)
-+++ testsuite/tests/typing-gadts/test.ml (working copy)
-@@ -159,17 +159,21 @@
-
- let ky x y = ignore (x = y); x ;;
-
-+let test : type a. a t -> a =
-+ function Int -> ky (1 : a) 1
-+;;
-+
- let test : type a. a t -> a = fun x ->
-- let r = match x with Int -> ky (1 : a) 1
-+ let r = match x with Int -> ky (1 : a) 1 (* fails *)
- in r
- ;;
- let test : type a. a t -> a = fun x ->
-- let r = match x with Int -> ky 1 (1 : a)
-+ let r = match x with Int -> ky 1 (1 : a) (* fails *)
- in r
- ;;
- let test : type a. a t -> a = fun x ->
-- let r = match x with Int -> (1 : a)
-- in r (* fails too *)
-+ let r = match x with Int -> (1 : a) (* ok! *)
-+ in r
- ;;
- let test : type a. a t -> a = fun x ->
- let r : a = match x with Int -> 1
-@@ -178,7 +182,7 @@
- let test2 : type a. a t -> a option = fun x ->
- let r = ref None in
- begin match x with Int -> r := Some (1 : a) end;
-- !r (* normalized to int option *)
-+ !r (* ok *)
- ;;
- let test2 : type a. a t -> a option = fun x ->
- let r : a option ref = ref None in
-@@ -190,19 +194,19 @@
- let u = ref None in
- begin match x with Int -> r := Some 1; u := !r end;
- !u
--;; (* fail *)
-+;; (* ok (u non-ambiguous) *)
- let test2 : type a. a t -> a option = fun x ->
- let r : a option ref = ref None in
- let u = ref None in
- begin match x with Int -> u := Some 1; r := !u end;
- !u
--;; (* fail *)
-+;; (* fails because u : (int | a) option ref *)
- let test2 : type a. a t -> a option = fun x ->
- let u = ref None in
- let r : a option ref = ref None in
- begin match x with Int -> r := Some 1; u := !r end;
- !u
--;; (* fail *)
-+;; (* ok *)
- let test2 : type a. a t -> a option = fun x ->
- let u = ref None in
- let a =
-@@ -210,32 +214,32 @@
- begin match x with Int -> r := Some 1; u := !r end;
- !u
- in a
--;; (* fail *)
-+;; (* ok *)
-
- (* Effect of external consraints *)
-
- let f (type a) (x : a t) y =
- ignore (y : a);
-- let r = match x with Int -> (y : a) in (* fails *)
-+ let r = match x with Int -> (y : a) in (* ok *)
- r
- ;;
- let f (type a) (x : a t) y =
- let r = match x with Int -> (y : a) in
-- ignore (y : a); (* fails *)
-+ ignore (y : a); (* ok *)
- r
- ;;
- let f (type a) (x : a t) y =
- ignore (y : a);
-- let r = match x with Int -> y in
-+ let r = match x with Int -> y in (* ok *)
- r
- ;;
- let f (type a) (x : a t) y =
- let r = match x with Int -> y in
-- ignore (y : a);
-+ ignore (y : a); (* ok *)
- r
- ;;
- let f (type a) (x : a t) (y : a) =
-- match x with Int -> y (* should return an int! *)
-+ match x with Int -> y (* returns 'a *)
- ;;
-
- (* Pattern matching *)
-@@ -307,4 +311,4 @@
- | {left=TE TC; right=D [|1.0|]} -> 14
- | {left=TA; right=D 0} -> -1
- | {left=TA; right=D z} -> z
--;; (* warn *)
-+;; (* ok *)
+++ /dev/null
-Index: boot/ocamlc
-===================================================================
-Cannot display: file marked as a binary type.
-svn:mime-type = application/octet-stream
-Index: boot/ocamldep
-===================================================================
-Cannot display: file marked as a binary type.
-svn:mime-type = application/octet-stream
-Index: boot/ocamllex
-===================================================================
-Cannot display: file marked as a binary type.
-svn:mime-type = application/octet-stream
-Index: camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
-===================================================================
---- camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml (revision 14301)
-+++ camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml (working copy)
-@@ -979,7 +979,7 @@
- [ <:module_type@loc<>> -> error loc "abstract/nil module type not allowed here"
- | <:module_type@loc< $id:i$ >> -> mkmty loc (Pmty_ident (long_uident i))
- | <:module_type@loc< functor ($n$ : $nt$) -> $mt$ >> ->
-- mkmty loc (Pmty_functor (with_loc n loc) (module_type nt) (module_type mt))
-+ mkmty loc (Pmty_functor (with_loc n loc) (Some (module_type nt)) (module_type mt))
- | <:module_type@loc< '$_$ >> -> error loc "module type variable not allowed here"
- | <:module_type@loc< sig $sl$ end >> ->
- mkmty loc (Pmty_signature (sig_item sl []))
-@@ -1051,7 +1051,7 @@
- | <:module_expr@loc< $me1$ $me2$ >> ->
- mkmod loc (Pmod_apply (module_expr me1) (module_expr me2))
- | <:module_expr@loc< functor ($n$ : $mt$) -> $me$ >> ->
-- mkmod loc (Pmod_functor (with_loc n loc) (module_type mt) (module_expr me))
-+ mkmod loc (Pmod_functor (with_loc n loc) (Some (module_type mt)) (module_expr me))
- | <:module_expr@loc< struct $sl$ end >> ->
- mkmod loc (Pmod_structure (str_item sl []))
- | <:module_expr@loc< ($me$ : $mt$) >> ->
-Index: camlp4/Camlp4Top/Rprint.ml
-===================================================================
---- camlp4/Camlp4Top/Rprint.ml (revision 14301)
-+++ camlp4/Camlp4Top/Rprint.ml (working copy)
-@@ -362,7 +362,10 @@
- | Omty_signature sg ->
- fprintf ppf "@[<hv 2>sig@ %a@;<1 -2>end@]"
- Toploop.print_out_signature.val sg
-- | Omty_functor name mty_arg mty_res ->
-+ | Omty_functor _ None mty_res ->
-+ fprintf ppf "@[<2>functor@ () ->@ %a@]"
-+ print_out_module_type mty_res
-+ | Omty_functor name (Some mty_arg) mty_res ->
- fprintf ppf "@[<2>functor@ (%s : %a) ->@ %a@]" name
- print_out_module_type mty_arg print_out_module_type mty_res
- | Omty_abstract -> () ]
-Index: camlp4/boot/Camlp4.ml
-===================================================================
---- camlp4/boot/Camlp4.ml (revision 14301)
-+++ camlp4/boot/Camlp4.ml (working copy)
-@@ -15633,7 +15633,7 @@
- | Ast.MtId (loc, i) -> mkmty loc (Pmty_ident (long_uident i))
- | Ast.MtFun (loc, n, nt, mt) ->
- mkmty loc
-- (Pmty_functor ((with_loc n loc), (module_type nt),
-+ (Pmty_functor ((with_loc n loc), Some (module_type nt),
- (module_type mt)))
- | Ast.MtQuo (loc, _) ->
- error loc "module type variable not allowed here"
-@@ -15775,7 +15775,7 @@
- (Pmod_apply ((module_expr me1), (module_expr me2)))
- | Ast.MeFun (loc, n, mt, me) ->
- mkmod loc
-- (Pmod_functor ((with_loc n loc), (module_type mt),
-+ (Pmod_functor ((with_loc n loc), Some (module_type mt),
- (module_expr me)))
- | Ast.MeStr (loc, sl) ->
- mkmod loc (Pmod_structure (str_item sl []))
-Index: ocamldoc/odoc_ast.ml
-===================================================================
---- ocamldoc/odoc_ast.ml (revision 14301)
-+++ ocamldoc/odoc_ast.ml (working copy)
-@@ -1606,18 +1606,25 @@
-
- | (Parsetree.Pmod_functor (_, pmodule_type, p_module_expr2),
- Typedtree.Tmod_functor (ident, _, mtyp, tt_module_expr2)) ->
-- let loc_start = pmodule_type.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in
-- let loc_end = pmodule_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
-+ let loc = match pmodule_type with None -> Location.none
-+ | Some pmty -> pmty.Parsetree.pmty_loc in
-+ let loc_start = loc.Location.loc_start.Lexing.pos_cnum in
-+ let loc_end = loc.Location.loc_end.Lexing.pos_cnum in
- let mp_type_code = get_string_of_file loc_start loc_end in
- print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code);
- let mp_name = Name.from_ident ident in
-- let mp_kind = Sig.analyse_module_type_kind env
-- current_module_name pmodule_type mtyp.mty_type
-+ let mp_kind =
-+ match pmodule_type, mtyp with
-+ Some pmty, Some mty ->
-+ Sig.analyse_module_type_kind env current_module_name pmty
-+ mty.mty_type
-+ | _ -> Module_type_struct []
- in
- let param =
- {
- mp_name = mp_name ;
-- mp_type = Odoc_env.subst_module_type env mtyp.mty_type ;
-+ mp_type = Misc.may_map
-+ (fun m -> Odoc_env.subst_module_type env m.mty_type) mtyp ;
- mp_type_code = mp_type_code ;
- mp_kind = mp_kind ;
- }
-Index: ocamldoc/odoc_env.ml
-===================================================================
---- ocamldoc/odoc_env.ml (revision 14301)
-+++ ocamldoc/odoc_env.ml (working copy)
-@@ -223,7 +223,7 @@
- | Types.Mty_signature _ ->
- t
- | Types.Mty_functor (id, mt1, mt2) ->
-- Types.Mty_functor (id, iter mt1, iter mt2)
-+ Types.Mty_functor (id, Misc.may_map iter mt1, iter mt2)
- in
- iter t
-
-Index: ocamldoc/odoc_html.ml
-===================================================================
---- ocamldoc/odoc_html.ml (revision 14301)
-+++ ocamldoc/odoc_html.ml (working copy)
-@@ -1384,7 +1384,8 @@
-
- (** Print html code to display the type of a module parameter.. *)
- method html_of_module_parameter_type b m_name p =
-- self#html_of_module_type b m_name ~code: p.mp_type_code p.mp_type
-+ match p.mp_type with None -> bs b "<code>()</code>"
-+ | Some mty -> self#html_of_module_type b m_name ~code: p.mp_type_code mty
-
- (** Generate a file containing the module type in the given file name. *)
- method output_module_type in_title file mtyp =
-Index: ocamldoc/odoc_info.mli
-===================================================================
---- ocamldoc/odoc_info.mli (revision 14301)
-+++ ocamldoc/odoc_info.mli (working copy)
-@@ -434,7 +434,7 @@
-
- and module_parameter = Odoc_module.module_parameter = {
- mp_name : string ; (** the name *)
-- mp_type : Types.module_type ; (** the type *)
-+ mp_type : Types.module_type option ; (** the type *)
- mp_type_code : string ; (** the original code *)
- mp_kind : module_type_kind ; (** the way the parameter was built *)
- }
-Index: ocamldoc/odoc_man.ml
-===================================================================
---- ocamldoc/odoc_man.ml (revision 14301)
-+++ ocamldoc/odoc_man.ml (working copy)
-@@ -612,7 +612,7 @@
- (fun (p, desc_opt) ->
- bs b ".sp\n";
- bs b ("\""^p.mp_name^"\"\n");
-- self#man_of_module_type b m_name p.mp_type;
-+ Misc.may (self#man_of_module_type b m_name) p.mp_type;
- bs b "\n";
- (
- match desc_opt with
-Index: ocamldoc/odoc_module.ml
-===================================================================
---- ocamldoc/odoc_module.ml (revision 14301)
-+++ ocamldoc/odoc_module.ml (working copy)
-@@ -46,7 +46,7 @@
-
- and module_parameter = {
- mp_name : string ; (** the name *)
-- mp_type : Types.module_type ; (** the type *)
-+ mp_type : Types.module_type option ; (** the type *)
- mp_type_code : string ; (** the original code *)
- mp_kind : module_type_kind ; (** the way the parameter was built *)
- }
-Index: ocamldoc/odoc_print.ml
-===================================================================
---- ocamldoc/odoc_print.ml (revision 14301)
-+++ ocamldoc/odoc_print.ml (working copy)
-@@ -62,7 +62,7 @@
- | Some s -> raise (Use_code s)
- )
- | Types.Mty_functor (id, mt1, mt2) ->
-- Types.Mty_functor (id, iter mt1, iter mt2)
-+ Types.Mty_functor (id, Misc.may_map iter mt1, iter mt2)
- in
- iter t
-
-Index: ocamldoc/odoc_sig.ml
-===================================================================
---- ocamldoc/odoc_sig.ml (revision 14301)
-+++ ocamldoc/odoc_sig.ml (working copy)
-@@ -1082,19 +1082,26 @@
-
- | Parsetree.Pmty_functor (_, pmodule_type2, module_type2) ->
- (
-- let loc_start = pmodule_type2.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in
-- let loc_end = pmodule_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
-+ let loc = match pmodule_type2 with None -> Location.none
-+ | Some pmty -> pmty.Parsetree.pmty_loc in
-+ let loc_start = loc.Location.loc_start.Lexing.pos_cnum in
-+ let loc_end = loc.Location.loc_end.Lexing.pos_cnum in
- let mp_type_code = get_string_of_file loc_start loc_end in
- print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code);
- match sig_module_type with
- Types.Mty_functor (ident, param_module_type, body_module_type) ->
-- let mp_kind = analyse_module_type_kind env
-- current_module_name pmodule_type2 param_module_type
-+ let mp_kind =
-+ match pmodule_type2, param_module_type with
-+ Some pmty, Some mty ->
-+ analyse_module_type_kind env current_module_name pmty mty
-+ | _ -> Module_type_struct []
- in
- let param =
- {
- mp_name = Name.from_ident ident ;
-- mp_type = Odoc_env.subst_module_type env param_module_type ;
-+ mp_type =
-+ Misc.may_map (Odoc_env.subst_module_type env)
-+ param_module_type;
- mp_type_code = mp_type_code ;
- mp_kind = mp_kind ;
- }
-@@ -1161,17 +1168,23 @@
- (
- match sig_module_type with
- Types.Mty_functor (ident, param_module_type, body_module_type) ->
-- let loc_start = pmodule_type2.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in
-- let loc_end = pmodule_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
-+ let loc = match pmodule_type2 with None -> Location.none
-+ | Some pmty -> pmty.Parsetree.pmty_loc in
-+ let loc_start = loc.Location.loc_start.Lexing.pos_cnum in
-+ let loc_end = loc.Location.loc_end.Lexing.pos_cnum in
- let mp_type_code = get_string_of_file loc_start loc_end in
- print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code);
-- let mp_kind = analyse_module_type_kind env
-- current_module_name pmodule_type2 param_module_type
-+ let mp_kind =
-+ match pmodule_type2, param_module_type with
-+ Some pmty, Some mty ->
-+ analyse_module_type_kind env current_module_name pmty mty
-+ | _ -> Module_type_struct []
- in
- let param =
- {
- mp_name = Name.from_ident ident ;
-- mp_type = Odoc_env.subst_module_type env param_module_type ;
-+ mp_type = Misc.may_map
-+ (Odoc_env.subst_module_type env) param_module_type ;
- mp_type_code = mp_type_code ;
- mp_kind = mp_kind ;
- }
-Index: ocamldoc/odoc_to_text.ml
-===================================================================
---- ocamldoc/odoc_to_text.ml (revision 14301)
-+++ ocamldoc/odoc_to_text.ml (working copy)
-@@ -428,8 +428,11 @@
- List
- (List.map
- (fun (p, desc_opt) ->
-- [Code (p.mp_name^" : ")] @
-- (self#text_of_module_type p.mp_type) @
-+ begin match p.mp_type with None -> [Raw ""]
-+ | Some mty ->
-+ [Code (p.mp_name^" : ")] @
-+ (self#text_of_module_type mty)
-+ end @
- (match desc_opt with
- None -> []
- | Some t -> (Raw " ") :: t)
-Index: parsing/ast_helper.mli
-===================================================================
---- parsing/ast_helper.mli (revision 14301)
-+++ parsing/ast_helper.mli (working copy)
-@@ -145,7 +145,8 @@
-
- val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type
- val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type
-- val functor_: ?loc:loc -> ?attrs:attrs -> str -> module_type -> module_type -> module_type
-+ val functor_: ?loc:loc -> ?attrs:attrs ->
-+ str -> module_type option -> module_type -> module_type
- val with_: ?loc:loc -> ?attrs:attrs -> module_type -> with_constraint list -> module_type
- val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type
- val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type
-@@ -159,7 +160,8 @@
-
- val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr
- val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr
-- val functor_: ?loc:loc -> ?attrs:attrs -> str -> module_type -> module_expr -> module_expr
-+ val functor_: ?loc:loc -> ?attrs:attrs ->
-+ str -> module_type option -> module_expr -> module_expr
- val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr -> module_expr
- val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type -> module_expr
- val unpack: ?loc:loc -> ?attrs:attrs -> expression -> module_expr
-Index: parsing/ast_mapper.ml
-===================================================================
---- parsing/ast_mapper.ml (revision 14301)
-+++ parsing/ast_mapper.ml (working copy)
-@@ -161,7 +161,8 @@
- | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s)
- | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg)
- | Pmty_functor (s, mt1, mt2) ->
-- functor_ ~loc ~attrs (map_loc sub s) (sub.module_type sub mt1)
-+ functor_ ~loc ~attrs (map_loc sub s)
-+ (Misc.may_map (sub.module_type sub) mt1)
- (sub.module_type sub mt2)
- | Pmty_with (mt, l) ->
- with_ ~loc ~attrs (sub.module_type sub mt)
-@@ -213,7 +214,8 @@
- | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x)
- | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str)
- | Pmod_functor (arg, arg_ty, body) ->
-- functor_ ~loc ~attrs (map_loc sub arg) (sub.module_type sub arg_ty)
-+ functor_ ~loc ~attrs (map_loc sub arg)
-+ (Misc.may_map (sub.module_type sub) arg_ty)
- (sub.module_expr sub body)
- | Pmod_apply (m1, m2) ->
- apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2)
-Index: parsing/parser.mly
-===================================================================
---- parsing/parser.mly (revision 14301)
-+++ parsing/parser.mly (working copy)
-@@ -541,9 +541,13 @@
- | STRUCT structure error
- { unclosed "struct" 1 "end" 3 }
- | FUNCTOR LPAREN UIDENT COLON module_type RPAREN MINUSGREATER module_expr
-- { mkmod(Pmod_functor(mkrhs $3 3, $5, $8)) }
-+ { mkmod(Pmod_functor(mkrhs $3 3, Some $5, $8)) }
-+ | FUNCTOR LPAREN RPAREN MINUSGREATER module_expr
-+ { mkmod(Pmod_functor(mkrhs "()" 3, None, $5)) }
- | module_expr LPAREN module_expr RPAREN
- { mkmod(Pmod_apply($1, $3)) }
-+ | module_expr LPAREN RPAREN
-+ { mkmod(Pmod_apply($1, mkmod (Pmod_structure []))) }
- | module_expr LPAREN module_expr error
- { unclosed "(" 2 ")" 4 }
- | LPAREN module_expr COLON module_type RPAREN
-@@ -640,7 +644,9 @@
- | COLON module_type EQUAL module_expr
- { mkmod(Pmod_constraint($4, $2)) }
- | LPAREN UIDENT COLON module_type RPAREN module_binding_body
-- { mkmod(Pmod_functor(mkrhs $2 2, $4, $6)) }
-+ { mkmod(Pmod_functor(mkrhs $2 2, Some $4, $6)) }
-+ | LPAREN RPAREN module_binding_body
-+ { mkmod(Pmod_functor(mkrhs "()" 1, None, $3)) }
- ;
- module_bindings:
- module_binding { [$1] }
-@@ -662,7 +668,10 @@
- { unclosed "sig" 1 "end" 3 }
- | FUNCTOR LPAREN UIDENT COLON module_type RPAREN MINUSGREATER module_type
- %prec below_WITH
-- { mkmty(Pmty_functor(mkrhs $3 3, $5, $8)) }
-+ { mkmty(Pmty_functor(mkrhs $3 3, Some $5, $8)) }
-+ | FUNCTOR LPAREN RPAREN MINUSGREATER module_type
-+ %prec below_WITH
-+ { mkmty(Pmty_functor(mkrhs "()" 2, None, $5)) }
- | module_type WITH with_constraints
- { mkmty(Pmty_with($1, List.rev $3)) }
- | MODULE TYPE OF module_expr %prec below_LBRACKETAT
-@@ -724,7 +733,9 @@
- COLON module_type
- { $2 }
- | LPAREN UIDENT COLON module_type RPAREN module_declaration
-- { mkmty(Pmty_functor(mkrhs $2 2, $4, $6)) }
-+ { mkmty(Pmty_functor(mkrhs $2 2, Some $4, $6)) }
-+ | LPAREN RPAREN module_declaration
-+ { mkmty(Pmty_functor(mkrhs "()" 1, None, $3)) }
- ;
- module_rec_declarations:
- module_rec_declaration { [$1] }
-Index: parsing/parsetree.mli
-===================================================================
---- parsing/parsetree.mli (revision 14301)
-+++ parsing/parsetree.mli (working copy)
-@@ -543,7 +543,7 @@
- (* S *)
- | Pmty_signature of signature
- (* sig ... end *)
-- | Pmty_functor of string loc * module_type * module_type
-+ | Pmty_functor of string loc * module_type option * module_type
- (* functor(X : MT1) -> MT2 *)
- | Pmty_with of module_type * with_constraint list
- (* MT with ... *)
-@@ -637,7 +637,7 @@
- (* X *)
- | Pmod_structure of structure
- (* struct ... end *)
-- | Pmod_functor of string loc * module_type * module_expr
-+ | Pmod_functor of string loc * module_type option * module_expr
- (* functor(X : MT1) -> ME *)
- | Pmod_apply of module_expr * module_expr
- (* ME1(ME2) *)
-Index: parsing/pprintast.ml
-===================================================================
---- parsing/pprintast.ml (revision 14301)
-+++ parsing/pprintast.ml (working copy)
-@@ -834,7 +834,9 @@
- | Pmty_signature (s) ->
- pp f "@[<hv0>@[<hv2>sig@ %a@]@ end@]" (* "@[<hov>sig@ %a@ end@]" *)
- (self#list self#signature_item ) s (* FIXME wrong indentation*)
-- | Pmty_functor (s, mt1, mt2) ->
-+ | Pmty_functor (_, None, mt2) ->
-+ pp f "@[<hov2>functor () ->@ %a@]" self#module_type mt2
-+ | Pmty_functor (s, Some mt1, mt2) ->
- pp f "@[<hov2>functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt
- self#module_type mt1 self#module_type mt2
- | Pmty_with (mt, l) ->
-@@ -940,7 +942,9 @@
- self#module_type mt
- | Pmod_ident (li) ->
- pp f "%a" self#longident_loc li;
-- | Pmod_functor (s, mt, me) ->
-+ | Pmod_functor (_, None, me) ->
-+ pp f "functor ()@;->@;%a" self#module_expr me
-+ | Pmod_functor (s, Some mt, me) ->
- pp f "functor@ (%s@ :@ %a)@;->@;%a"
- s.txt self#module_type mt self#module_expr me
- | Pmod_apply (me1, me2) ->
-@@ -1025,7 +1029,8 @@
- | Pstr_module x ->
- let rec module_helper me = match me.pmod_desc with
- | Pmod_functor(s,mt,me) ->
-- pp f "(%s:%a)" s.txt self#module_type mt ;
-+ if mt = None then pp f "()"
-+ else Misc.may (pp f "(%s:%a)" s.txt self#module_type) mt;
- module_helper me
- | _ -> me in
- pp f "@[<hov2>module %s%a@]"
-Index: parsing/printast.ml
-===================================================================
---- parsing/printast.ml (revision 14301)
-+++ parsing/printast.ml (working copy)
-@@ -576,7 +576,7 @@
- signature i ppf s;
- | Pmty_functor (s, mt1, mt2) ->
- line i ppf "Pmty_functor %a\n" fmt_string_loc s;
-- module_type i ppf mt1;
-+ Misc.may (module_type i ppf) mt1;
- module_type i ppf mt2;
- | Pmty_with (mt, l) ->
- line i ppf "Pmty_with\n";
-@@ -670,7 +670,7 @@
- structure i ppf s;
- | Pmod_functor (s, mt, me) ->
- line i ppf "Pmod_functor %a\n" fmt_string_loc s;
-- module_type i ppf mt;
-+ Misc.may (module_type i ppf) mt;
- module_expr i ppf me;
- | Pmod_apply (me1, me2) ->
- line i ppf "Pmod_apply\n";
-Index: tools/depend.ml
-===================================================================
---- tools/depend.ml (revision 14301)
-+++ tools/depend.ml (working copy)
-@@ -201,7 +201,8 @@
- Pmty_ident l -> add bv l
- | Pmty_signature s -> add_signature bv s
- | Pmty_functor(id, mty1, mty2) ->
-- add_modtype bv mty1; add_modtype (StringSet.add id.txt bv) mty2
-+ Misc.may (add_modtype bv) mty1;
-+ add_modtype (StringSet.add id.txt bv) mty2
- | Pmty_with(mty, cstrl) ->
- add_modtype bv mty;
- List.iter
-@@ -258,7 +259,7 @@
- Pmod_ident l -> addmodule bv l
- | Pmod_structure s -> ignore (add_structure bv s)
- | Pmod_functor(id, mty, modl) ->
-- add_modtype bv mty;
-+ Misc.may (add_modtype bv) mty;
- add_module (StringSet.add id.txt bv) modl
- | Pmod_apply(mod1, mod2) ->
- add_module bv mod1; add_module bv mod2
-Index: tools/tast_iter.ml
-===================================================================
---- tools/tast_iter.ml (revision 14301)
-+++ tools/tast_iter.ml (working copy)
-@@ -193,7 +193,7 @@
- | Tmty_ident (_path, _) -> ()
- | Tmty_signature sg -> sub # signature sg
- | Tmty_functor (_id, _, mtype1, mtype2) ->
-- sub # module_type mtype1; sub # module_type mtype2
-+ Misc.may (sub # module_type) mtype1; sub # module_type mtype2
- | Tmty_with (mtype, list) ->
- sub # module_type mtype;
- List.iter (fun (_, _, withc) -> sub # with_constraint withc) list
-@@ -212,7 +212,7 @@
- | Tmod_ident (_p, _) -> ()
- | Tmod_structure st -> sub # structure st
- | Tmod_functor (_id, _, mtype, mexpr) ->
-- sub # module_type mtype;
-+ Misc.may (sub # module_type) mtype;
- sub # module_expr mexpr
- | Tmod_apply (mexp1, mexp2, _) ->
- sub # module_expr mexp1;
-Index: tools/untypeast.ml
-===================================================================
---- tools/untypeast.ml (revision 14301)
-+++ tools/untypeast.ml (working copy)
-@@ -376,7 +376,7 @@
- Tmty_ident (_path, lid) -> Pmty_ident (lid)
- | Tmty_signature sg -> Pmty_signature (untype_signature sg)
- | Tmty_functor (_id, name, mtype1, mtype2) ->
-- Pmty_functor (name, untype_module_type mtype1,
-+ Pmty_functor (name, Misc.may_map untype_module_type mtype1,
- untype_module_type mtype2)
- | Tmty_with (mtype, list) ->
- Pmty_with (untype_module_type mtype,
-@@ -405,7 +405,7 @@
- Tmod_ident (_p, lid) -> Pmod_ident (lid)
- | Tmod_structure st -> Pmod_structure (untype_structure st)
- | Tmod_functor (_id, name, mtype, mexpr) ->
-- Pmod_functor (name, untype_module_type mtype,
-+ Pmod_functor (name, Misc.may_map untype_module_type mtype,
- untype_module_expr mexpr)
- | Tmod_apply (mexp1, mexp2, _) ->
- Pmod_apply (untype_module_expr mexp1, untype_module_expr mexp2)
-Index: typing/btype.ml
-===================================================================
---- typing/btype.ml (revision 14301)
-+++ typing/btype.ml (working copy)
-@@ -56,6 +56,9 @@
- let is_Tunivar = function {desc=Tunivar _} -> true | _ -> false
-
- let dummy_method = "*dummy method*"
-+let default_mty = function
-+ Some mty -> mty
-+ | None -> Mty_signature []
-
- (**** Representative of a type ****)
-
-Index: typing/btype.mli
-===================================================================
---- typing/btype.mli (revision 14301)
-+++ typing/btype.mli (working copy)
-@@ -39,9 +39,12 @@
- (* Return a fresh marked generic variable *)
- *)
-
-+(**** Types ****)
-+
- val is_Tvar: type_expr -> bool
- val is_Tunivar: type_expr -> bool
- val dummy_method: label
-+val default_mty: module_type option -> module_type
-
- val repr: type_expr -> type_expr
- (* Return the canonical representative of a type. *)
-Index: typing/env.ml
-===================================================================
---- typing/env.ml (revision 14301)
-+++ typing/env.ml (working copy)
-@@ -201,7 +201,7 @@
-
- and functor_components = {
- fcomp_param: Ident.t; (* Formal parameter *)
-- fcomp_arg: module_type; (* Argument signature *)
-+ fcomp_arg: module_type option; (* Argument signature *)
- fcomp_res: module_type; (* Result signature *)
- fcomp_env: t; (* Environment in which the result signature makes sense *)
- fcomp_subst: Subst.t; (* Prefixing substitution for the result signature *)
-@@ -522,7 +522,7 @@
- let (p2, {md_type=mty2}) = lookup_module l2 env in
- begin match EnvLazy.force !components_of_module_maker' desc1 with
- Functor_comps f ->
-- !check_modtype_inclusion env mty2 p2 f.fcomp_arg;
-+ Misc.may (!check_modtype_inclusion env mty2 p2) f.fcomp_arg;
- (Papply(p1, p2), !components_of_functor_appl' f p1 p2)
- | Structure_comps c ->
- raise Not_found
-@@ -562,7 +562,7 @@
- let p = Papply(p1, p2) in
- begin match EnvLazy.force !components_of_module_maker' desc1 with
- Functor_comps f ->
-- !check_modtype_inclusion env mty2 p2 f.fcomp_arg;
-+ Misc.may (!check_modtype_inclusion env mty2 p2) f.fcomp_arg;
- let mty =
- Subst.modtype (Subst.add_module f.fcomp_param p2 f.fcomp_subst)
- f.fcomp_res in
-@@ -1120,7 +1120,7 @@
- fcomp_param = param;
- (* fcomp_arg must be prefixed eagerly, because it is interpreted
- in the outer environment, not in env *)
-- fcomp_arg = Subst.modtype sub ty_arg;
-+ fcomp_arg = may_map (Subst.modtype sub) ty_arg;
- (* fcomp_res is prefixed lazily, because it is interpreted in env *)
- fcomp_res = ty_res;
- fcomp_env = env;
-Index: typing/includemod.ml
-===================================================================
---- typing/includemod.ml (revision 14301)
-+++ typing/includemod.ml (working copy)
-@@ -168,7 +168,13 @@
- try_modtypes2 env cxt mty1 (Subst.modtype subst mty2)
- | (Mty_signature sig1, Mty_signature sig2) ->
- signatures env cxt subst sig1 sig2
-- | (Mty_functor(param1, arg1, res1), Mty_functor(param2, arg2, res2)) ->
-+ | (Mty_functor(param1, None, res1), Mty_functor(param2, None, res2)) ->
-+ begin match modtypes env (Body param1::cxt) subst res1 res2 with
-+ Tcoerce_none -> Tcoerce_none
-+ | cc -> Tcoerce_functor (Tcoerce_none, cc)
-+ end
-+ | (Mty_functor(param1, Some arg1, res1),
-+ Mty_functor(param2, Some arg2, res2)) ->
- let arg2' = Subst.modtype subst arg2 in
- let cc_arg = modtypes env (Arg param1::cxt) Subst.identity arg2' arg1 in
- let cc_res =
-Index: typing/mtype.ml
-===================================================================
---- typing/mtype.ml (revision 14301)
-+++ typing/mtype.ml (working copy)
-@@ -34,7 +34,8 @@
- match scrape env mty with
- Mty_signature sg ->
- Mty_signature(strengthen_sig env sg p)
-- | Mty_functor(param, arg, res) when !Clflags.applicative_functors ->
-+ | Mty_functor(param, arg, res)
-+ when !Clflags.applicative_functors && Ident.name param <> "*" ->
- Mty_functor(param, arg, strengthen env res (Papply(p, Pident param)))
- | mty ->
- mty
-@@ -105,8 +106,9 @@
- | Mty_functor(param, arg, res) ->
- let var_inv =
- match va with Co -> Contra | Contra -> Co | Strict -> Strict in
-- Mty_functor(param, nondep_mty env var_inv arg,
-- nondep_mty (Env.add_module param arg env) va res)
-+ Mty_functor(param, Misc.may_map (nondep_mty env var_inv) arg,
-+ nondep_mty
-+ (Env.add_module param (Btype.default_mty arg) env) va res)
-
- and nondep_sig env va = function
- [] -> []
-@@ -228,3 +230,34 @@
- no_code_needed_sig env rem
- | (Sig_exception _ | Sig_class _) :: rem ->
- false
-+
-+
-+(* Check whether a module type may return types *)
-+
-+let rec contains_type env = function
-+ Mty_ident path ->
-+ (try Misc.may (contains_type env) (Env.find_modtype path env).mtd_type
-+ with Not_found -> raise Exit)
-+ | Mty_signature sg ->
-+ contains_type_sig env sg
-+ | Mty_functor (_, _, body) ->
-+ contains_type env body
-+
-+and contains_type_sig env = List.iter (contains_type_item env)
-+
-+and contains_type_item env = function
-+ Sig_type (_,({type_manifest = None} |
-+ {type_kind = Type_abstract; type_private = Private}),_)
-+ | Sig_modtype _ ->
-+ raise Exit
-+ | Sig_module (_, {md_type = mty}, _) ->
-+ contains_type env mty
-+ | Sig_value _
-+ | Sig_type _
-+ | Sig_exception _
-+ | Sig_class _
-+ | Sig_class_type _ ->
-+ ()
-+
-+let contains_type env mty =
-+ try contains_type env mty; false with Exit -> true
-Index: typing/mtype.mli
-===================================================================
---- typing/mtype.mli (revision 14301)
-+++ typing/mtype.mli (working copy)
-@@ -36,3 +36,4 @@
- val enrich_modtype: Env.t -> Path.t -> module_type -> module_type
- val enrich_typedecl: Env.t -> Path.t -> type_declaration -> type_declaration
- val type_paths: Env.t -> Path.t -> module_type -> Path.t list
-+val contains_type: Env.t -> module_type -> bool
-Index: typing/oprint.ml
-===================================================================
---- typing/oprint.ml (revision 14301)
-+++ typing/oprint.ml (working copy)
-@@ -344,7 +344,9 @@
- let rec print_out_module_type ppf =
- function
- Omty_abstract -> ()
-- | Omty_functor (name, mty_arg, mty_res) ->
-+ | Omty_functor (_, None, mty_res) ->
-+ fprintf ppf "@[<2>functor@ () ->@ %a@]" print_out_module_type mty_res
-+ | Omty_functor (name, Some mty_arg, mty_res) ->
- fprintf ppf "@[<2>functor@ (%s : %a) ->@ %a@]" name
- print_out_module_type mty_arg print_out_module_type mty_res
- | Omty_ident id -> fprintf ppf "%a" print_ident id
-Index: typing/outcometree.mli
-===================================================================
---- typing/outcometree.mli (revision 14301)
-+++ typing/outcometree.mli (working copy)
-@@ -75,7 +75,7 @@
-
- type out_module_type =
- | Omty_abstract
-- | Omty_functor of string * out_module_type * out_module_type
-+ | Omty_functor of string * out_module_type option * out_module_type
- | Omty_ident of out_ident
- | Omty_signature of out_sig_item list
- and out_sig_item =
-Index: typing/printtyp.ml
-===================================================================
---- typing/printtyp.ml (revision 14301)
-+++ typing/printtyp.ml (working copy)
-@@ -1116,9 +1116,12 @@
- | Mty_signature sg ->
- Omty_signature (tree_of_signature sg)
- | Mty_functor(param, ty_arg, ty_res) ->
-- Omty_functor
-- (Ident.name param, tree_of_modtype ty_arg,
-- wrap_env (Env.add_module param ty_arg) tree_of_modtype ty_res)
-+ let res =
-+ match ty_arg with None -> tree_of_modtype ty_res
-+ | Some mty ->
-+ wrap_env (Env.add_module param mty) tree_of_modtype ty_res
-+ in
-+ Omty_functor (Ident.name param, may_map tree_of_modtype ty_arg, res)
-
- and tree_of_signature sg =
- wrap_env (fun env -> env) (tree_of_signature_rec !printing_env) sg
-Index: typing/printtyped.ml
-===================================================================
---- typing/printtyped.ml (revision 14301)
-+++ typing/printtyped.ml (working copy)
-@@ -562,7 +562,7 @@
- signature i ppf s;
- | Tmty_functor (s, _, mt1, mt2) ->
- line i ppf "Pmty_functor \"%a\"\n" fmt_ident s;
-- module_type i ppf mt1;
-+ Misc.may (module_type i ppf) mt1;
- module_type i ppf mt2;
- | Tmty_with (mt, l) ->
- line i ppf "Pmty_with\n";
-@@ -651,7 +651,7 @@
- structure i ppf s;
- | Tmod_functor (s, _, mt, me) ->
- line i ppf "Pmod_functor \"%a\"\n" fmt_ident s;
-- module_type i ppf mt;
-+ Misc.may (module_type i ppf) mt;
- module_expr i ppf me;
- | Tmod_apply (me1, me2, _) ->
- line i ppf "Pmod_apply\n";
-Index: typing/subst.ml
-===================================================================
---- typing/subst.ml (revision 14301)
-+++ typing/subst.ml (working copy)
-@@ -327,8 +327,8 @@
- Mty_signature(signature s sg)
- | Mty_functor(id, arg, res) ->
- let id' = Ident.rename id in
-- Mty_functor(id', modtype s arg,
-- modtype (add_module id (Pident id') s) res)
-+ Mty_functor(id', may_map (modtype s) arg,
-+ modtype (add_module id (Pident id') s) res)
-
- and signature s sg =
- (* Components of signature may be mutually recursive (e.g. type declarations
-Index: typing/typedtree.ml
-===================================================================
---- typing/typedtree.ml (revision 14301)
-+++ typing/typedtree.ml (working copy)
-@@ -187,7 +187,7 @@
- and module_expr_desc =
- Tmod_ident of Path.t * Longident.t loc
- | Tmod_structure of structure
-- | Tmod_functor of Ident.t * string loc * module_type * module_expr
-+ | Tmod_functor of Ident.t * string loc * module_type option * module_expr
- | Tmod_apply of module_expr * module_expr * module_coercion
- | Tmod_constraint of
- module_expr * Types.module_type * module_type_constraint * module_coercion
-@@ -253,7 +253,7 @@
- and module_type_desc =
- Tmty_ident of Path.t * Longident.t loc
- | Tmty_signature of signature
-- | Tmty_functor of Ident.t * string loc * module_type * module_type
-+ | Tmty_functor of Ident.t * string loc * module_type option * module_type
- | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list
- | Tmty_typeof of module_expr
-
-Index: typing/typedtree.mli
-===================================================================
---- typing/typedtree.mli (revision 14301)
-+++ typing/typedtree.mli (working copy)
-@@ -186,7 +186,7 @@
- and module_expr_desc =
- Tmod_ident of Path.t * Longident.t loc
- | Tmod_structure of structure
-- | Tmod_functor of Ident.t * string loc * module_type * module_expr
-+ | Tmod_functor of Ident.t * string loc * module_type option * module_expr
- | Tmod_apply of module_expr * module_expr * module_coercion
- | Tmod_constraint of
- module_expr * Types.module_type * module_type_constraint * module_coercion
-@@ -252,7 +252,7 @@
- and module_type_desc =
- Tmty_ident of Path.t * Longident.t loc
- | Tmty_signature of signature
-- | Tmty_functor of Ident.t * string loc * module_type * module_type
-+ | Tmty_functor of Ident.t * string loc * module_type option * module_type
- | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list
- | Tmty_typeof of module_expr
-
-Index: typing/typedtreeIter.ml
-===================================================================
---- typing/typedtreeIter.ml (revision 14301)
-+++ typing/typedtreeIter.ml (working copy)
-@@ -383,7 +383,7 @@
- Tmty_ident (path, _) -> ()
- | Tmty_signature sg -> iter_signature sg
- | Tmty_functor (id, _, mtype1, mtype2) ->
-- iter_module_type mtype1; iter_module_type mtype2
-+ Misc.may iter_module_type mtype1; iter_module_type mtype2
- | Tmty_with (mtype, list) ->
- iter_module_type mtype;
- List.iter (fun (path, _, withc) ->
-@@ -412,7 +412,7 @@
- Tmod_ident (p, _) -> ()
- | Tmod_structure st -> iter_structure st
- | Tmod_functor (id, _, mtype, mexpr) ->
-- iter_module_type mtype;
-+ Misc.may iter_module_type mtype;
- iter_module_expr mexpr
- | Tmod_apply (mexp1, mexp2, _) ->
- iter_module_expr mexp1;
-Index: typing/typedtreeMap.ml
-===================================================================
---- typing/typedtreeMap.ml (revision 14301)
-+++ typing/typedtreeMap.ml (working copy)
-@@ -426,7 +426,7 @@
- Tmty_ident (path, lid) -> mty.mty_desc
- | Tmty_signature sg -> Tmty_signature (map_signature sg)
- | Tmty_functor (id, name, mtype1, mtype2) ->
-- Tmty_functor (id, name, map_module_type mtype1,
-+ Tmty_functor (id, name, Misc.may_map map_module_type mtype1,
- map_module_type mtype2)
- | Tmty_with (mtype, list) ->
- Tmty_with (map_module_type mtype,
-@@ -456,7 +456,7 @@
- Tmod_ident (p, lid) -> mexpr.mod_desc
- | Tmod_structure st -> Tmod_structure (map_structure st)
- | Tmod_functor (id, name, mtype, mexpr) ->
-- Tmod_functor (id, name, map_module_type mtype,
-+ Tmod_functor (id, name, Misc.may_map map_module_type mtype,
- map_module_expr mexpr)
- | Tmod_apply (mexp1, mexp2, coercion) ->
- Tmod_apply (map_module_expr mexp1, map_module_expr mexp2, coercion)
-Index: typing/typemod.ml
-===================================================================
---- typing/typemod.ml (revision 14301)
-+++ typing/typemod.ml (working copy)
-@@ -39,6 +39,7 @@
- | Scoping_pack of Longident.t * type_expr
- | Extension of string
- | Recursive_module_require_explicit_type
-+ | Apply_generative
-
- exception Error of Location.t * Env.t * error
-
-@@ -299,8 +300,9 @@
- | Pmty_signature ssg ->
- Mty_signature(approx_sig env ssg)
- | Pmty_functor(param, sarg, sres) ->
-- let arg = approx_modtype env sarg in
-- let (id, newenv) = Env.enter_module param.txt arg env in
-+ let arg = may_map (approx_modtype env) sarg in
-+ let (id, newenv) =
-+ Env.enter_module param.txt (Btype.default_mty arg) env in
- let res = approx_modtype newenv sres in
- Mty_functor(id, arg, res)
- | Pmty_with(sbody, constraints) ->
-@@ -472,11 +474,13 @@
- mkmty (Tmty_signature sg) (Mty_signature sg.sig_type) env loc
- smty.pmty_attributes
- | Pmty_functor(param, sarg, sres) ->
-- let arg = transl_modtype env sarg in
-- let (id, newenv) = Env.enter_module param.txt arg.mty_type env in
-+ let arg = Misc.may_map (transl_modtype env) sarg in
-+ let ty_arg = Misc.may_map (fun m -> m.mty_type) arg in
-+ let (id, newenv) =
-+ Env.enter_module param.txt (Btype.default_mty ty_arg) env in
- let res = transl_modtype newenv sres in
- mkmty (Tmty_functor (id, param, arg, res))
-- (Mty_functor(id, arg.mty_type, res.mty_type)) env loc
-+ (Mty_functor(id, ty_arg, res.mty_type)) env loc
- smty.pmty_attributes
- | Pmty_with(sbody, constraints) ->
- let body = transl_modtype env sbody in
-@@ -949,11 +953,14 @@
- mod_attributes = smod.pmod_attributes;
- mod_loc = smod.pmod_loc }
- | Pmod_functor(name, smty, sbody) ->
-- let mty = transl_modtype env smty in
-- let (id, newenv) = Env.enter_module name.txt mty.mty_type env in
-- let body = type_module sttn true None newenv sbody in
-+ let mty = may_map (transl_modtype env) smty in
-+ let ty_arg = may_map (fun m -> m.mty_type) mty in
-+ let (id, newenv), funct_body =
-+ match ty_arg with None -> (Ident.create "*", env), false
-+ | Some mty -> Env.enter_module name.txt mty env, true in
-+ let body = type_module sttn funct_body None newenv sbody in
- rm { mod_desc = Tmod_functor(id, name, mty, body);
-- mod_type = Mty_functor(id, mty.mty_type, body.mod_type);
-+ mod_type = Mty_functor(id, ty_arg, body.mod_type);
- mod_env = env;
- mod_attributes = smod.pmod_attributes;
- mod_loc = smod.pmod_loc }
-@@ -964,6 +971,14 @@
- type_module (sttn && path <> None) funct_body None env sfunct in
- begin match Mtype.scrape env funct.mod_type with
- Mty_functor(param, mty_param, mty_res) as mty_functor ->
-+ let generative, mty_param =
-+ (mty_param = None, Btype.default_mty mty_param) in
-+ if generative then begin
-+ if sarg.pmod_desc <> Pmod_structure [] then
-+ raise (Error (sfunct.pmod_loc, env, Apply_generative));
-+ if funct_body && Mtype.contains_type env funct.mod_type then
-+ raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body));
-+ end;
- let coercion =
- try
- Includemod.modtypes env arg.mod_type mty_param
-@@ -975,6 +990,7 @@
- Subst.modtype (Subst.add_module param path Subst.identity)
- mty_res
- | None ->
-+ if generative then mty_res else
- try
- Mtype.nondep_supertype
- (Env.add_module param arg.mod_type env) param mty_res
-@@ -999,8 +1015,6 @@
- }
-
- | Pmod_unpack sexp ->
-- if funct_body then
-- raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body));
- if !Clflags.principal then Ctype.begin_def ();
- let exp = Typecore.type_exp env sexp in
- if !Clflags.principal then begin
-@@ -1025,6 +1039,8 @@
- | _ ->
- raise (Error(smod.pmod_loc, env, Not_a_packed_module exp.exp_type))
- in
-+ if funct_body && Mtype.contains_type env mty then
-+ raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body));
- rm { mod_desc = Tmod_unpack(exp, mty);
- mod_type = mty;
- mod_env = env;
-@@ -1549,7 +1565,8 @@
- Location.print_filename intf_name
- | Not_allowed_in_functor_body ->
- fprintf ppf
-- "This kind of expression is not allowed within the body of a functor."
-+ "@[This expression creates fresh types.@ %s@]"
-+ "It is not allowed inside applicative functors."
- | With_need_typeconstr ->
- fprintf ppf
- "Only type constructors with identical parameters can be substituted."
-@@ -1570,6 +1587,8 @@
- fprintf ppf "Uninterpreted extension '%s'." s
- | Recursive_module_require_explicit_type ->
- fprintf ppf "Recursive modules require an explicit module type."
-+ | Apply_generative ->
-+ fprintf ppf "This is a generative functor. It can only be applied to ()"
-
- let report_error env ppf err =
- Printtyp.wrap_printing_env env (fun () -> report_error ppf err)
-Index: typing/typemod.mli
-===================================================================
---- typing/typemod.mli (revision 14301)
-+++ typing/typemod.mli (working copy)
-@@ -60,6 +60,7 @@
- | Scoping_pack of Longident.t * type_expr
- | Extension of string
- | Recursive_module_require_explicit_type
-+ | Apply_generative
-
- exception Error of Location.t * Env.t * error
-
-Index: typing/types.ml
-===================================================================
---- typing/types.ml (revision 14301)
-+++ typing/types.ml (working copy)
-@@ -264,7 +264,7 @@
- type module_type =
- Mty_ident of Path.t
- | Mty_signature of signature
-- | Mty_functor of Ident.t * module_type * module_type
-+ | Mty_functor of Ident.t * module_type option * module_type
-
- and signature = signature_item list
-
-Index: typing/types.mli
-===================================================================
---- typing/types.mli (revision 14301)
-+++ typing/types.mli (working copy)
-@@ -251,7 +251,7 @@
- type module_type =
- Mty_ident of Path.t
- | Mty_signature of signature
-- | Mty_functor of Ident.t * module_type * module_type
-+ | Mty_functor of Ident.t * module_type option * module_type
-
- and signature = signature_item list
-
+++ /dev/null
-Index: parsing/parser.mly
-===================================================================
---- parsing/parser.mly (revision 14285)
-+++ parsing/parser.mly (working copy)
-@@ -542,8 +542,12 @@
- { unclosed "struct" 1 "end" 3 }
- | FUNCTOR LPAREN UIDENT COLON module_type RPAREN MINUSGREATER module_expr
- { mkmod(Pmod_functor(mkrhs $3 3, $5, $8)) }
-+ | FUNCTOR LPAREN RPAREN MINUSGREATER module_expr
-+ { mkmod(Pmod_functor(mkrhs "*" 3, mkmty (Pmty_signature []), $5)) }
- | module_expr LPAREN module_expr RPAREN
- { mkmod(Pmod_apply($1, $3)) }
-+ | module_expr LPAREN RPAREN
-+ { mkmod(Pmod_apply($1, mkmod (Pmod_structure []))) }
- | module_expr LPAREN module_expr error
- { unclosed "(" 2 ")" 4 }
- | LPAREN module_expr COLON module_type RPAREN
-@@ -641,6 +645,8 @@
- { mkmod(Pmod_constraint($4, $2)) }
- | LPAREN UIDENT COLON module_type RPAREN module_binding_body
- { mkmod(Pmod_functor(mkrhs $2 2, $4, $6)) }
-+ | LPAREN RPAREN module_binding_body
-+ { mkmod(Pmod_functor(mkrhs "*" 1, mkmty(Pmty_signature []), $3)) }
- ;
- module_bindings:
- module_binding { [$1] }
-@@ -663,6 +669,9 @@
- | FUNCTOR LPAREN UIDENT COLON module_type RPAREN MINUSGREATER module_type
- %prec below_WITH
- { mkmty(Pmty_functor(mkrhs $3 3, $5, $8)) }
-+ | FUNCTOR LPAREN RPAREN MINUSGREATER module_type
-+ %prec below_WITH
-+ { mkmty(Pmty_functor(mkrhs "*" 2, mkmty(Pmty_signature []), $5)) }
- | module_type WITH with_constraints
- { mkmty(Pmty_with($1, List.rev $3)) }
- | MODULE TYPE OF module_expr %prec below_LBRACKETAT
-@@ -725,6 +734,8 @@
- { $2 }
- | LPAREN UIDENT COLON module_type RPAREN module_declaration
- { mkmty(Pmty_functor(mkrhs $2 2, $4, $6)) }
-+ | LPAREN RPAREN module_declaration
-+ { mkmty(Pmty_functor(mkrhs "*" 1, mkmty (Pmty_signature []), $3)) }
- ;
- module_rec_declarations:
- module_rec_declaration { [$1] }
-Index: parsing/pprintast.ml
-===================================================================
---- parsing/pprintast.ml (revision 14285)
-+++ parsing/pprintast.ml (working copy)
-@@ -834,6 +834,8 @@
- | Pmty_signature (s) ->
- pp f "@[<hv0>@[<hv2>sig@ %a@]@ end@]" (* "@[<hov>sig@ %a@ end@]" *)
- (self#list self#signature_item ) s (* FIXME wrong indentation*)
-+ | Pmty_functor ({txt="*"}, mt1, mt2) ->
-+ pp f "@[<hov2>functor () ->@ %a@]" self#module_type mt2
- | Pmty_functor (s, mt1, mt2) ->
- pp f "@[<hov2>functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt
- self#module_type mt1 self#module_type mt2
-@@ -940,6 +942,8 @@
- self#module_type mt
- | Pmod_ident (li) ->
- pp f "%a" self#longident_loc li;
-+ | Pmod_functor ({txt="*"}, mt, me) ->
-+ pp f "functor ()@;->@;%a" self#module_expr me
- | Pmod_functor (s, mt, me) ->
- pp f "functor@ (%s@ :@ %a)@;->@;%a"
- s.txt self#module_type mt self#module_expr me
-@@ -1025,7 +1029,8 @@
- | Pstr_module x ->
- let rec module_helper me = match me.pmod_desc with
- | Pmod_functor(s,mt,me) ->
-- pp f "(%s:%a)" s.txt self#module_type mt ;
-+ if s.txt = "*" then pp f "()"
-+ else pp f "(%s:%a)" s.txt self#module_type mt ;
- module_helper me
- | _ -> me in
- pp f "@[<hov2>module %s%a@]"
-Index: typing/includemod.ml
-===================================================================
---- typing/includemod.ml (revision 14285)
-+++ typing/includemod.ml (working copy)
-@@ -35,6 +35,7 @@
- Ident.t * class_declaration * class_declaration *
- Ctype.class_match_failure list
- | Unbound_modtype_path of Path.t
-+ | Impure_functor
-
- type pos =
- Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
-@@ -165,6 +166,8 @@
- | (Mty_signature sig1, Mty_signature sig2) ->
- signatures env cxt subst sig1 sig2
- | (Mty_functor(param1, arg1, res1), Mty_functor(param2, arg2, res2)) ->
-+ if Ident.name param1 = "*" && Ident.name param2 <> "*" then
-+ raise (Error [cxt, env, Impure_functor]);
- let arg2' = Subst.modtype subst arg2 in
- let cc_arg = modtypes env (Arg param1::cxt) Subst.identity arg2' arg1 in
- let cc_res =
-@@ -422,6 +425,8 @@
- Includeclass.report_error reason
- | Unbound_modtype_path path ->
- fprintf ppf "Unbound module type %a" Printtyp.path path
-+ | Impure_functor ->
-+ fprintf ppf "An impure functor cannot be made applicative"
-
- let rec context ppf = function
- Module id :: rem ->
-Index: typing/includemod.mli
-===================================================================
---- typing/includemod.mli (revision 14285)
-+++ typing/includemod.mli (working copy)
-@@ -40,6 +40,7 @@
- Ident.t * class_declaration * class_declaration *
- Ctype.class_match_failure list
- | Unbound_modtype_path of Path.t
-+ | Impure_functor
-
- type pos =
- Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
-Index: typing/mtype.ml
-===================================================================
---- typing/mtype.ml (revision 14285)
-+++ typing/mtype.ml (working copy)
-@@ -34,7 +34,8 @@
- match scrape env mty with
- Mty_signature sg ->
- Mty_signature(strengthen_sig env sg p)
-- | Mty_functor(param, arg, res) when !Clflags.applicative_functors ->
-+ | Mty_functor(param, arg, res)
-+ when !Clflags.applicative_functors && Ident.name param <> "*" ->
- Mty_functor(param, arg, strengthen env res (Papply(p, Pident param)))
- | mty ->
- mty
-Index: typing/oprint.ml
-===================================================================
---- typing/oprint.ml (revision 14285)
-+++ typing/oprint.ml (working copy)
-@@ -344,6 +344,8 @@
- let rec print_out_module_type ppf =
- function
- Omty_abstract -> ()
-+ | Omty_functor ("*", _, mty_res) ->
-+ fprintf ppf "@[<2>functor@ () ->@ %a@]" print_out_module_type mty_res
- | Omty_functor (name, mty_arg, mty_res) ->
- fprintf ppf "@[<2>functor@ (%s : %a) ->@ %a@]" name
- print_out_module_type mty_arg print_out_module_type mty_res
-Index: typing/typemod.ml
-===================================================================
---- typing/typemod.ml (revision 14285)
-+++ typing/typemod.ml (working copy)
-@@ -39,6 +39,7 @@
- | Scoping_pack of Longident.t * type_expr
- | Extension of string
- | Recursive_module_require_explicit_type
-+ | Apply_impure
-
- exception Error of Location.t * Env.t * error
-
-@@ -950,8 +951,10 @@
- mod_loc = smod.pmod_loc }
- | Pmod_functor(name, smty, sbody) ->
- let mty = transl_modtype env smty in
-- let (id, newenv) = Env.enter_module name.txt mty.mty_type env in
-- let body = type_module sttn true None newenv sbody in
-+ let (id, newenv), funct_body =
-+ if name.txt = "*" then (Ident.create "*", env), false else
-+ Env.enter_module name.txt mty.mty_type env, true in
-+ let body = type_module sttn funct_body None newenv sbody in
- rm { mod_desc = Tmod_functor(id, name, mty, body);
- mod_type = Mty_functor(id, mty.mty_type, body.mod_type);
- mod_env = env;
-@@ -964,6 +967,13 @@
- type_module (sttn && path <> None) funct_body None env sfunct in
- begin match Mtype.scrape env funct.mod_type with
- Mty_functor(param, mty_param, mty_res) as mty_functor ->
-+ let impure = Ident.name param = "*" in
-+ if impure then begin
-+ if sarg.pmod_desc <> Pmod_structure [] then
-+ raise (Error (sfunct.pmod_loc, env, Apply_impure));
-+ if funct_body then
-+ raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body));
-+ end;
- let coercion =
- try
- Includemod.modtypes env arg.mod_type mty_param
-@@ -975,6 +985,7 @@
- Subst.modtype (Subst.add_module param path Subst.identity)
- mty_res
- | None ->
-+ if impure then mty_res else
- try
- Mtype.nondep_supertype
- (Env.add_module param arg.mod_type env) param mty_res
-@@ -1549,7 +1560,7 @@
- Location.print_filename intf_name
- | Not_allowed_in_functor_body ->
- fprintf ppf
-- "This kind of expression is not allowed within the body of a functor."
-+ "This kind of expression is only allowed inside impure functors."
- | With_need_typeconstr ->
- fprintf ppf
- "Only type constructors with identical parameters can be substituted."
-@@ -1570,6 +1581,8 @@
- fprintf ppf "Uninterpreted extension '%s'." s
- | Recursive_module_require_explicit_type ->
- fprintf ppf "Recursive modules require an explicit module type."
-+ | Apply_impure ->
-+ fprintf ppf "This functor is impure. It can only be applied to ()"
-
- let report_error env ppf err =
- Printtyp.wrap_printing_env env (fun () -> report_error ppf err)
-Index: typing/typemod.mli
-===================================================================
---- typing/typemod.mli (revision 14285)
-+++ typing/typemod.mli (working copy)
-@@ -60,6 +60,7 @@
- | Scoping_pack of Longident.t * type_expr
- | Extension of string
- | Recursive_module_require_explicit_type
-+ | Apply_impure
-
- exception Error of Location.t * Env.t * error
-
+++ /dev/null
-? bytecomp/alpha_eq.ml
-Index: bytecomp/lambda.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/lambda.ml,v
-retrieving revision 1.44
-diff -u -r1.44 lambda.ml
---- bytecomp/lambda.ml 25 Aug 2005 15:35:16 -0000 1.44
-+++ bytecomp/lambda.ml 2 Feb 2006 05:08:56 -0000
-@@ -287,9 +287,10 @@
- let compare = compare
- end)
-
--let free_ids get l =
-+let free_ids get used l =
- let fv = ref IdentSet.empty in
- let rec free l =
-+ let old = !fv in
- iter free l;
- fv := List.fold_right IdentSet.add (get l) !fv;
- match l with
-@@ -307,17 +308,20 @@
- fv := IdentSet.remove v !fv
- | Lassign(id, e) ->
- fv := IdentSet.add id !fv
-+ | Lifused(id, e) ->
-+ if used && not (IdentSet.mem id old) then fv := IdentSet.remove id !fv
- | Lvar _ | Lconst _ | Lapply _
- | Lprim _ | Lswitch _ | Lstaticraise _
- | Lifthenelse _ | Lsequence _ | Lwhile _
-- | Lsend _ | Levent _ | Lifused _ -> ()
-+ | Lsend _ | Levent _ -> ()
- in free l; !fv
-
--let free_variables l =
-- free_ids (function Lvar id -> [id] | _ -> []) l
-+let free_variables ?(ifused=false) l =
-+ free_ids (function Lvar id -> [id] | _ -> []) ifused l
-
- let free_methods l =
-- free_ids (function Lsend(Self, Lvar meth, obj, _) -> [meth] | _ -> []) l
-+ free_ids (function Lsend(Self, Lvar meth, obj, _) -> [meth] | _ -> [])
-+ false l
-
- (* Check if an action has a "when" guard *)
- let raise_count = ref 0
-Index: bytecomp/lambda.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/lambda.mli,v
-retrieving revision 1.42
-diff -u -r1.42 lambda.mli
---- bytecomp/lambda.mli 25 Aug 2005 15:35:16 -0000 1.42
-+++ bytecomp/lambda.mli 2 Feb 2006 05:08:56 -0000
-@@ -177,7 +177,7 @@
-
- val iter: (lambda -> unit) -> lambda -> unit
- module IdentSet: Set.S with type elt = Ident.t
--val free_variables: lambda -> IdentSet.t
-+val free_variables: ?ifused:bool -> lambda -> IdentSet.t
- val free_methods: lambda -> IdentSet.t
-
- val transl_path: Path.t -> lambda
-Index: bytecomp/translclass.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translclass.ml,v
-retrieving revision 1.38
-diff -u -r1.38 translclass.ml
---- bytecomp/translclass.ml 13 Aug 2005 20:59:37 -0000 1.38
-+++ bytecomp/translclass.ml 2 Feb 2006 05:08:56 -0000
-@@ -46,6 +46,10 @@
-
- let lfield v i = Lprim(Pfield i, [Lvar v])
-
-+let ltuple l = Lprim(Pmakeblock(0,Immutable), l)
-+
-+let lprim name args = Lapply(oo_prim name, args)
-+
- let transl_label l = share (Const_immstring l)
-
- let rec transl_meth_list lst =
-@@ -68,8 +72,8 @@
- Lvar offset])])]))
-
- let transl_val tbl create name =
-- Lapply (oo_prim (if create then "new_variable" else "get_variable"),
-- [Lvar tbl; transl_label name])
-+ lprim (if create then "new_variable" else "get_variable")
-+ [Lvar tbl; transl_label name]
-
- let transl_vals tbl create vals rem =
- List.fold_right
-@@ -82,7 +86,7 @@
- (fun (nm, id) rem ->
- try
- (nm, id,
-- Lapply(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)]))
-+ lprim "get_method" [Lvar tbl; Lvar (Meths.find nm meths)])
- :: rem
- with Not_found -> rem)
- inh_meths []
-@@ -97,17 +101,15 @@
- let (inh_init, obj_init, has_init) = init obj' in
- if obj_init = lambda_unit then
- (inh_init,
-- Lapply (oo_prim (if has_init then "create_object_and_run_initializers"
-- else"create_object_opt"),
-- [obj; Lvar cl]))
-+ lprim (if has_init then "create_object_and_run_initializers"
-+ else"create_object_opt")
-+ [obj; Lvar cl])
- else begin
- (inh_init,
-- Llet(Strict, obj',
-- Lapply (oo_prim "create_object_opt", [obj; Lvar cl]),
-+ Llet(Strict, obj', lprim "create_object_opt" [obj; Lvar cl],
- Lsequence(obj_init,
- if not has_init then Lvar obj' else
-- Lapply (oo_prim "run_initializers_opt",
-- [obj; Lvar obj'; Lvar cl]))))
-+ lprim "run_initializers_opt" [obj; Lvar obj'; Lvar cl])))
- end
-
- let rec build_object_init cl_table obj params inh_init obj_init cl =
-@@ -203,14 +205,13 @@
-
-
- let bind_method tbl lab id cl_init =
-- Llet(StrictOpt, id, Lapply (oo_prim "get_method_label",
-- [Lvar tbl; transl_label lab]),
-+ Llet(StrictOpt, id, lprim "get_method_label" [Lvar tbl; transl_label lab],
- cl_init)
-
--let bind_methods tbl meths vals cl_init =
-- let methl = Meths.fold (fun lab id tl -> (lab,id) :: tl) meths [] in
-+let bind_methods tbl methl vals cl_init =
- let len = List.length methl and nvals = List.length vals in
-- if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else
-+ if len < 2 && nvals = 0 then
-+ List.fold_right (fun (n,i) -> bind_method tbl n i) methl cl_init else
- if len = 0 && nvals < 2 then transl_vals tbl true vals cl_init else
- let ids = Ident.create "ids" in
- let i = ref len in
-@@ -229,21 +230,19 @@
- vals' cl_init)
- in
- Llet(StrictOpt, ids,
-- Lapply (oo_prim getter,
-- [Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
-+ lprim getter
-+ ([Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
- List.fold_right
-- (fun (lab,id) lam -> decr i; Llet(StrictOpt, id, lfield ids !i, lam))
-+ (fun (lab,id) lam -> decr i; Llet(Alias, id, lfield ids !i, lam))
- methl cl_init)
-
- let output_methods tbl methods lam =
- match methods with
- [] -> lam
- | [lab; code] ->
-- lsequence (Lapply(oo_prim "set_method", [Lvar tbl; lab; code])) lam
-+ lsequence (lprim "set_method" [Lvar tbl; lab; code]) lam
- | _ ->
-- lsequence (Lapply(oo_prim "set_methods",
-- [Lvar tbl; Lprim(Pmakeblock(0,Immutable), methods)]))
-- lam
-+ lsequence (lprim "set_methods" [Lvar tbl; ltuple methods]) lam
-
- let rec ignore_cstrs cl =
- match cl.cl_desc with
-@@ -266,7 +265,8 @@
- Llet (Strict, obj_init,
- Lapply(Lprim(Pfield 1, [lpath]), Lvar cla ::
- if top then [Lprim(Pfield 3, [lpath])] else []),
-- bind_super cla super cl_init))
-+ bind_super cla super cl_init),
-+ [], [])
- | _ ->
- assert false
- end
-@@ -278,10 +278,11 @@
- match field with
- Cf_inher (cl, vals, meths) ->
- let cl_init = output_methods cla methods cl_init in
-- let inh_init, cl_init =
-+ let (inh_init, cl_init, meths', vals') =
- build_class_init cla false
- (vals, meths_super cla str.cl_meths meths)
- inh_init cl_init msubst top cl in
-+ let cl_init = bind_methods cla meths' vals' cl_init in
- (inh_init, cl_init, [], values)
- | Cf_val (name, id, exp) ->
- (inh_init, cl_init, methods, (name, id)::values)
-@@ -304,29 +305,37 @@
- (inh_init, cl_init, methods, vals @ values)
- | Cf_init exp ->
- (inh_init,
-- Lsequence(Lapply (oo_prim "add_initializer",
-- Lvar cla :: msubst false (transl_exp exp)),
-+ Lsequence(lprim "add_initializer"
-+ (Lvar cla :: msubst false (transl_exp exp)),
- cl_init),
- methods, values))
- str.cl_field
- (inh_init, cl_init, [], [])
- in
- let cl_init = output_methods cla methods cl_init in
-- (inh_init, bind_methods cla str.cl_meths values cl_init)
-+ (* inh_init, bind_methods cla str.cl_meths values cl_init *)
-+ let methods = Meths.fold (fun n i l -> (n,i)::l) str.cl_meths [] in
-+ (inh_init, cl_init, methods, values)
- | Tclass_fun (pat, vals, cl, _) ->
-- let (inh_init, cl_init) =
-+ let (inh_init, cl_init, methods, values) =
- build_class_init cla cstr super inh_init cl_init msubst top cl
- in
-+ let fv = free_variables ~ifused:true cl_init in
-+ let vals = List.filter (fun (id,_) -> IdentSet.mem id fv) vals in
- let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in
-- (inh_init, transl_vals cla true vals cl_init)
-+ (* inh_init, transl_vals cla true vals cl_init *)
-+ (inh_init, cl_init, methods, vals @ values)
- | Tclass_apply (cl, exprs) ->
- build_class_init cla cstr super inh_init cl_init msubst top cl
- | Tclass_let (rec_flag, defs, vals, cl) ->
-- let (inh_init, cl_init) =
-+ let (inh_init, cl_init, methods, values) =
- build_class_init cla cstr super inh_init cl_init msubst top cl
- in
-+ let fv = free_variables ~ifused:true cl_init in
-+ let vals = List.filter (fun (id,_) -> IdentSet.mem id fv) vals in
- let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in
-- (inh_init, transl_vals cla true vals cl_init)
-+ (* inh_init, transl_vals cla true vals cl_init *)
-+ (inh_init, cl_init, methods, vals @ values)
- | Tclass_constraint (cl, vals, meths, concr_meths) ->
- let virt_meths =
- List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in
-@@ -358,23 +367,34 @@
- cl_init valids in
- (inh_init,
- Llet (Strict, inh,
-- Lapply(oo_prim "inherits", narrow_args @
-- [lpath; Lconst(Const_pointer(if top then 1 else 0))]),
-+ lprim "inherits"
-+ (narrow_args @
-+ [lpath; Lconst(Const_pointer(if top then 1 else 0))]),
- Llet(StrictOpt, obj_init, lfield inh 0,
- Llet(Alias, inh_vals, lfield inh 1,
-- Llet(Alias, inh_meths, lfield inh 2, cl_init)))))
-+ Llet(Alias, inh_meths, lfield inh 2, cl_init)))),
-+ [], [])
- | _ ->
- let core cl_init =
- build_class_init cla true super inh_init cl_init msubst top cl
- in
- if cstr then core cl_init else
-- let (inh_init, cl_init) =
-- core (Lsequence (Lapply (oo_prim "widen", [Lvar cla]), cl_init))
-+ let (inh_init, cl_init, methods, values) =
-+ core (Lsequence (lprim "widen" [Lvar cla], cl_init))
- in
-- (inh_init,
-- Lsequence(Lapply (oo_prim "narrow", narrow_args), cl_init))
-+ let cl_init = bind_methods cla methods values cl_init in
-+ (inh_init, Lsequence(lprim "narrow" narrow_args, cl_init), [], [])
- end
-
-+let build_class_init cla env inh_init obj_init msubst top cl =
-+ let inh_init = List.rev inh_init in
-+ let (inh_init, cl_init, methods, values) =
-+ build_class_init cla true ([],[]) inh_init obj_init msubst top cl in
-+ assert (inh_init = []);
-+ if IdentSet.mem env (free_variables ~ifused:true cl_init)
-+ then bind_methods cla methods (("", env) :: values) cl_init
-+ else Llet(Alias, env, lambda_unit, bind_methods cla methods values cl_init)
-+
- let rec build_class_lets cl =
- match cl.cl_desc with
- Tclass_let (rec_flag, defs, vals, cl) ->
-@@ -459,16 +479,16 @@
- Strict, new_init, lfunction [obj_init] obj_init',
- Llet(
- Alias, cla, transl_path path,
-- Lprim(Pmakeblock(0, Immutable),
-- [Lapply(Lvar new_init, [lfield cla 0]);
-- lfunction [table]
-- (Llet(Strict, env_init,
-- Lapply(lfield cla 1, [Lvar table]),
-- lfunction [envs]
-- (Lapply(Lvar new_init,
-- [Lapply(Lvar env_init, [Lvar envs])]))));
-- lfield cla 2;
-- lfield cla 3])))
-+ ltuple
-+ [Lapply(Lvar new_init, [lfield cla 0]);
-+ lfunction [table]
-+ (Llet(Strict, env_init,
-+ Lapply(lfield cla 1, [Lvar table]),
-+ lfunction [envs]
-+ (Lapply(Lvar new_init,
-+ [Lapply(Lvar env_init, [Lvar envs])]))));
-+ lfield cla 2;
-+ lfield cla 3]))
- with Exit ->
- lambda_unit
-
-@@ -541,7 +561,7 @@
- open CamlinternalOO
- let builtin_meths arr self env env2 body =
- let builtin, args = builtin_meths self env env2 body in
-- if not arr then [Lapply(oo_prim builtin, args)] else
-+ if not arr then [lprim builtin args] else
- let tag = match builtin with
- "get_const" -> GetConst
- | "get_var" -> GetVar
-@@ -599,7 +619,8 @@
-
- (* Prepare for heavy environment handling *)
- let tables = Ident.create (Ident.name cl_id ^ "_tables") in
-- let (top_env, req) = oo_add_class tables in
-+ let table_init = ref None in
-+ let (top_env, req) = oo_add_class tables table_init in
- let top = not req in
- let cl_env, llets = build_class_lets cl in
- let new_ids = if top then [] else Env.diff top_env cl_env in
-@@ -633,6 +654,7 @@
- begin try
- (* Doesn't seem to improve size for bytecode *)
- (* if not !Clflags.native_code then raise Not_found; *)
-+ if !Clflags.debug then raise Not_found;
- builtin_meths arr [self] env env2 (lfunction args body')
- with Not_found ->
- [lfunction (self :: args)
-@@ -665,15 +687,8 @@
- build_object_init_0 cla [] cl copy_env subst_env top ids in
- if not (Translcore.check_recursive_lambda ids obj_init) then
- raise(Error(cl.cl_loc, Illegal_class_expr));
-- let inh_init' = List.rev inh_init in
-- let (inh_init', cl_init) =
-- build_class_init cla true ([],[]) inh_init' obj_init msubst top cl
-- in
-- assert (inh_init' = []);
-- let table = Ident.create "table"
-- and class_init = Ident.create (Ident.name cl_id ^ "_init")
-- and env_init = Ident.create "env_init"
-- and obj_init = Ident.create "obj_init" in
-+ let cl_init = build_class_init cla env2 inh_init obj_init msubst top cl in
-+ let obj_init = Ident.create "obj_init" in
- let pub_meths =
- List.sort
- (fun s s' -> compare (Btype.hash_variant s) (Btype.hash_variant s'))
-@@ -685,42 +700,44 @@
- let name' = List.assoc tag rev_map in
- if name' <> name then raise(Error(cl.cl_loc, Tags(name, name'))))
- tags pub_meths;
-+ let pos = cl.cl_loc.Location.loc_end in
-+ let filepos = [transl_label pos.Lexing.pos_fname;
-+ Lconst(Const_base(Const_int pos.Lexing.pos_cnum))] in
- let ltable table lam =
-- Llet(Strict, table,
-- Lapply (oo_prim "create_table", [transl_meth_list pub_meths]), lam)
-+ Llet(Strict, table, lprim "create_table" [transl_meth_list pub_meths], lam)
- and ldirect obj_init =
- Llet(Strict, obj_init, cl_init,
-- Lsequence(Lapply (oo_prim "init_class", [Lvar cla]),
-+ Lsequence(lprim "init_class_shared" (Lvar cla :: filepos),
- Lapply(Lvar obj_init, [lambda_unit])))
- in
- (* Simplest case: an object defined at toplevel (ids=[]) *)
- if top && ids = [] then llets (ltable cla (ldirect obj_init)) else
-
-+ let table = Ident.create "table"
-+ and class_init = Ident.create (Ident.name cl_id ^ "_init")
-+ and env_init = Ident.create (Ident.name cl_id ^ "_env_init") in
-+ let cl_init_fun = Lfunction(Curried, [cla], cl_init) in
- let concrete =
- ids = [] ||
- Typeclass.virtual_methods (Ctype.signature_of_class_type cl.cl_type) = []
-- and lclass lam =
-- let cl_init = llets (Lfunction(Curried, [cla], cl_init)) in
-+ and lclass cl_init lam =
- Llet(Strict, class_init, cl_init, lam (free_variables cl_init))
- and lbody fv =
- if List.for_all (fun id -> not (IdentSet.mem id fv)) ids then
-- Lapply (oo_prim "make_class",[transl_meth_list pub_meths;
-- Lvar class_init])
-+ lprim "make_class"
-+ (transl_meth_list pub_meths :: Lvar class_init :: filepos)
- else
- ltable table (
- Llet(
- Strict, env_init, Lapply(Lvar class_init, [Lvar table]),
-- Lsequence(
-- Lapply (oo_prim "init_class", [Lvar table]),
-- Lprim(Pmakeblock(0, Immutable),
-- [Lapply(Lvar env_init, [lambda_unit]);
-- Lvar class_init; Lvar env_init; lambda_unit]))))
-+ Lsequence(lprim "init_class_shared" (Lvar table :: filepos),
-+ ltuple [Lapply(Lvar env_init, [lambda_unit]);
-+ Lvar class_init; Lvar env_init; lambda_unit])))
- and lbody_virt lenvs =
-- Lprim(Pmakeblock(0, Immutable),
-- [lambda_unit; Lfunction(Curried,[cla], cl_init); lambda_unit; lenvs])
-+ ltuple [lambda_unit; cl_init_fun; lambda_unit; lenvs]
- in
- (* Still easy: a class defined at toplevel *)
-- if top && concrete then lclass lbody else
-+ if top && concrete then lclass (llets cl_init_fun) lbody else
- if top then llets (lbody_virt lambda_unit) else
-
- (* Now for the hard stuff: prepare for table cacheing *)
-@@ -733,23 +750,16 @@
- let lenv =
- let menv =
- if !new_ids_meths = [] then lambda_unit else
-- Lprim(Pmakeblock(0, Immutable),
-- List.map (fun id -> Lvar id) !new_ids_meths) in
-+ ltuple (List.map (fun id -> Lvar id) !new_ids_meths) in
- if !new_ids_init = [] then menv else
-- Lprim(Pmakeblock(0, Immutable),
-- menv :: List.map (fun id -> Lvar id) !new_ids_init)
-+ ltuple (menv :: List.map (fun id -> Lvar id) !new_ids_init)
- and linh_envs =
- List.map (fun (_, p) -> Lprim(Pfield 3, [transl_path p]))
- (List.rev inh_init)
- in
- let make_envs lam =
- Llet(StrictOpt, envs,
-- (if linh_envs = [] then lenv else
-- Lprim(Pmakeblock(0, Immutable), lenv :: linh_envs)),
-- lam)
-- and def_ids cla lam =
-- Llet(StrictOpt, env2,
-- Lapply (oo_prim "new_variable", [Lvar cla; transl_label ""]),
-+ (if linh_envs = [] then lenv else ltuple (lenv :: linh_envs)),
- lam)
- in
- let inh_paths =
-@@ -757,46 +767,53 @@
- (fun (_,path) -> List.mem (Path.head path) new_ids) inh_init in
- let inh_keys =
- List.map (fun (_,p) -> Lprim(Pfield 1, [transl_path p])) inh_paths in
-- let lclass lam =
-- Llet(Strict, class_init,
-- Lfunction(Curried, [cla], def_ids cla cl_init), lam)
-+ let lclass_init lam =
-+ Llet(Strict, class_init, cl_init_fun, lam)
- and lcache lam =
- if inh_keys = [] then Llet(Alias, cached, Lvar tables, lam) else
-- Llet(Strict, cached,
-- Lapply(oo_prim "lookup_tables",
-- [Lvar tables; Lprim(Pmakeblock(0, Immutable), inh_keys)]),
-+ Llet(Strict, cached, lprim "lookup_tables" [Lvar tables; ltuple inh_keys],
- lam)
- and lset cached i lam =
- Lprim(Psetfield(i, true), [Lvar cached; lam])
- in
-- let ldirect () =
-- ltable cla
-- (Llet(Strict, env_init, def_ids cla cl_init,
-- Lsequence(Lapply (oo_prim "init_class", [Lvar cla]),
-- lset cached 0 (Lvar env_init))))
-- and lclass_virt () =
-- lset cached 0 (Lfunction(Curried, [cla], def_ids cla cl_init))
-+ let ldirect prim pos =
-+ ltable cla (
-+ Llet(Strict, env_init, cl_init,
-+ Lsequence(lprim prim (Lvar cla :: pos), Lvar env_init)))
-+ and lclass_concrete cached =
-+ ltuple [Lapply (lfield cached 0, [lenvs]);
-+ lfield cached 1; lfield cached 0; lenvs]
- in
-+
- llets (
-- lcache (
-- Lsequence(
-- Lifthenelse(lfield cached 0, lambda_unit,
-- if ids = [] then ldirect () else
-- if not concrete then lclass_virt () else
-- lclass (
-- Lapply (oo_prim "make_class_store",
-- [transl_meth_list pub_meths;
-- Lvar class_init; Lvar cached]))),
- make_envs (
-- if ids = [] then Lapply(lfield cached 0, [lenvs]) else
-- Lprim(Pmakeblock(0, Immutable),
-- if concrete then
-- [Lapply(lfield cached 0, [lenvs]);
-- lfield cached 1;
-- lfield cached 0;
-- lenvs]
-- else [lambda_unit; lfield cached 0; lambda_unit; lenvs]
-- )))))
-+ if inh_paths = [] && concrete then
-+ if ids = [] then begin
-+ table_init := Some (ldirect "init_class_shared" filepos);
-+ Lapply (Lvar tables, [lenvs])
-+ end else begin
-+ let init =
-+ lclass cl_init_fun (fun _ ->
-+ lprim "make_class_env"
-+ (transl_meth_list pub_meths :: Lvar class_init :: filepos))
-+ in table_init := Some init;
-+ lclass_concrete tables
-+ end
-+ else begin
-+ lcache (
-+ Lsequence(
-+ Lifthenelse(lfield cached 0, lambda_unit,
-+ if ids = [] then lset cached 0 (ldirect "init_class" []) else
-+ if not concrete then lset cached 0 cl_init_fun else
-+ lclass_init (
-+ lprim "make_class_store"
-+ [transl_meth_list pub_meths; Lvar class_init; Lvar cached])),
-+ llets (
-+ make_envs (
-+ if ids = [] then Lapply(lfield cached 0, [lenvs]) else
-+ if concrete then lclass_concrete cached else
-+ ltuple [lambda_unit; lfield cached 0; lambda_unit; lenvs]))))
-+ end))
-
- (* Wrapper for class compilation *)
-
-Index: bytecomp/translobj.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translobj.ml,v
-retrieving revision 1.9
-diff -u -r1.9 translobj.ml
---- bytecomp/translobj.ml 26 May 2004 11:10:51 -0000 1.9
-+++ bytecomp/translobj.ml 2 Feb 2006 05:08:56 -0000
-@@ -88,7 +88,6 @@
-
- (* Insert labels *)
-
--let string s = Lconst (Const_base (Const_string s))
- let int n = Lconst (Const_base (Const_int n))
-
- let prim_makearray =
-@@ -124,8 +123,8 @@
- let top_env = ref Env.empty
- let classes = ref []
-
--let oo_add_class id =
-- classes := id :: !classes;
-+let oo_add_class id init =
-+ classes := (id, init) :: !classes;
- (!top_env, !cache_required)
-
- let oo_wrap env req f x =
-@@ -141,10 +140,12 @@
- let lambda = f x in
- let lambda =
- List.fold_left
-- (fun lambda id ->
-+ (fun lambda (id, init) ->
- Llet(StrictOpt, id,
-- Lprim(Pmakeblock(0, Mutable),
-- [lambda_unit; lambda_unit; lambda_unit]),
-+ (match !init with
-+ Some lam -> lam
-+ | None -> Lprim(Pmakeblock(0, Mutable),
-+ [lambda_unit; lambda_unit; lambda_unit])),
- lambda))
- lambda !classes
- in
-Index: bytecomp/translobj.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translobj.mli,v
-retrieving revision 1.6
-diff -u -r1.6 translobj.mli
---- bytecomp/translobj.mli 26 May 2004 11:10:51 -0000 1.6
-+++ bytecomp/translobj.mli 2 Feb 2006 05:08:56 -0000
-@@ -25,4 +25,4 @@
- Ident.t -> int -> ('a -> lambda) -> 'a -> int * lambda
-
- val oo_wrap: Env.t -> bool -> ('a -> lambda) -> 'a -> lambda
--val oo_add_class: Ident.t -> Env.t * bool
-+val oo_add_class: Ident.t -> Lambda.lambda option ref -> Env.t * bool
-Index: byterun/compare.h
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/byterun/compare.h,v
-retrieving revision 1.2
-diff -u -r1.2 compare.h
---- byterun/compare.h 31 Dec 2003 14:20:35 -0000 1.2
-+++ byterun/compare.h 2 Feb 2006 05:08:56 -0000
-@@ -17,5 +17,6 @@
- #define CAML_COMPARE_H
-
- CAMLextern int caml_compare_unordered;
-+CAMLextern value caml_compare(value, value);
-
- #endif /* CAML_COMPARE_H */
-Index: byterun/extern.c
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/byterun/extern.c,v
-retrieving revision 1.59
-diff -u -r1.59 extern.c
---- byterun/extern.c 4 Jan 2006 16:55:49 -0000 1.59
-+++ byterun/extern.c 2 Feb 2006 05:08:56 -0000
-@@ -411,6 +411,22 @@
- extern_record_location(v);
- break;
- }
-+ case Object_tag: {
-+ value field0;
-+ mlsize_t i;
-+ i = Wosize_val(Field(v, 0)) - 1;
-+ field0 = Field(Field(v, 0),i);
-+ if (Wosize_val(field0) > 0) {
-+ writecode32(CODE_OBJECT, Wosize_hd (hd));
-+ extern_record_location(v);
-+ extern_rec(field0);
-+ for (i = 1; i < sz - 1; i++) extern_rec(Field(v, i));
-+ v = Field(v, i);
-+ goto tailcall;
-+ }
-+ if (!extern_closures)
-+ extern_invalid_argument("output_value: dynamic class");
-+ } /* may fall through */
- default: {
- value field0;
- mlsize_t i;
-Index: byterun/intern.c
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/byterun/intern.c,v
-retrieving revision 1.60
-diff -u -r1.60 intern.c
---- byterun/intern.c 22 Sep 2005 14:21:50 -0000 1.60
-+++ byterun/intern.c 2 Feb 2006 05:08:56 -0000
-@@ -28,6 +28,8 @@
- #include "mlvalues.h"
- #include "misc.h"
- #include "reverse.h"
-+#include "callback.h"
-+#include "compare.h"
-
- static unsigned char * intern_src;
- /* Reading pointer in block holding input data. */
-@@ -98,6 +100,25 @@
- #define readblock(dest,len) \
- (memmove((dest), intern_src, (len)), intern_src += (len))
-
-+static value get_method_table (value key)
-+{
-+ static value *classes = NULL;
-+ value current;
-+ if (classes == NULL) {
-+ classes = caml_named_value("caml_oo_classes");
-+ if (classes == NULL) return 0;
-+ caml_register_global_root(classes);
-+ }
-+ for (current = Field(*classes, 0); Is_block(current);
-+ current = Field(current, 1))
-+ {
-+ value head = Field(current, 0);
-+ if (caml_compare(key, Field(head, 0)) == Val_int(0))
-+ return Field(head, 1);
-+ }
-+ return 0;
-+}
-+
- static void intern_cleanup(void)
- {
- if (intern_input_malloced) caml_stat_free(intern_input);
-@@ -315,6 +336,24 @@
- Custom_ops_val(v) = ops;
- intern_dest += 1 + size;
- break;
-+ case CODE_OBJECT:
-+ size = read32u();
-+ v = Val_hp(intern_dest);
-+ *dest = v;
-+ if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v;
-+ dest = (value *) (intern_dest + 1);
-+ *intern_dest = Make_header(size, Object_tag, intern_color);
-+ intern_dest += 1 + size;
-+ intern_rec(dest);
-+ *dest = get_method_table(*dest);
-+ if (*dest == 0) {
-+ intern_cleanup();
-+ caml_failwith("input_value: unknown class");
-+ }
-+ for(size--, dest++; size > 1; size--, dest++)
-+ intern_rec(dest);
-+ goto tailcall;
-+
- default:
- intern_cleanup();
- caml_failwith("input_value: ill-formed message");
-Index: byterun/intext.h
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/byterun/intext.h,v
-retrieving revision 1.32
-diff -u -r1.32 intext.h
---- byterun/intext.h 22 Sep 2005 14:21:50 -0000 1.32
-+++ byterun/intext.h 2 Feb 2006 05:08:56 -0000
-@@ -56,6 +56,7 @@
- #define CODE_CODEPOINTER 0x10
- #define CODE_INFIXPOINTER 0x11
- #define CODE_CUSTOM 0x12
-+#define CODE_OBJECT 0x14
-
- #if ARCH_FLOAT_ENDIANNESS == 0x76543210
- #define CODE_DOUBLE_NATIVE CODE_DOUBLE_BIG
-Index: stdlib/camlinternalOO.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.ml,v
-retrieving revision 1.14
-diff -u -r1.14 camlinternalOO.ml
---- stdlib/camlinternalOO.ml 25 Oct 2005 18:34:07 -0000 1.14
-+++ stdlib/camlinternalOO.ml 2 Feb 2006 05:08:56 -0000
-@@ -305,10 +305,38 @@
- public_methods;
- table
-
-+(*
-+let create_table_variables pub_meths priv_meths vars =
-+ let tbl = create_table pub_meths in
-+ let pub_meths = to_array pub_meths
-+ and priv_meths = to_array priv_meths
-+ and vars = to_array vars in
-+ let len = 2 + Array.length pub_meths + Array.length priv_meths in
-+ let res = Array.create len tbl in
-+ let mv = new_methods_variables tbl pub_meths vars in
-+ Array.blit mv 0 res 1;
-+ res
-+*)
-+
- let init_class table =
- inst_var_count := !inst_var_count + table.size - 1;
- table.initializers <- List.rev table.initializers;
-- resize table (3 + magic table.methods.(1) * 16 / Sys.word_size)
-+ let len = 3 + magic table.methods.(1) * 16 / Sys.word_size in
-+ (* keep 1 more for extra info *)
-+ let len = if len > Array.length table.methods then len else len+1 in
-+ resize table len
-+
-+let classes = ref []
-+let () = Callback.register "caml_oo_classes" classes
-+
-+let init_class_shared table (file : string) (pos : int) =
-+ init_class table;
-+ let rec unique_pos pos =
-+ if List.mem_assoc (file, pos) !classes then unique_pos (pos + 0x100000)
-+ else pos in
-+ let pos = unique_pos pos in
-+ table.methods.(Array.length table.methods - 1) <- Obj.magic (file, pos);
-+ classes := ((file, pos), table.methods) :: !classes
-
- let inherits cla vals virt_meths concr_meths (_, super, _, env) top =
- narrow cla vals virt_meths concr_meths;
-@@ -319,12 +347,18 @@
- Array.map (fun nm -> get_method cla (get_method_label cla nm))
- (to_array concr_meths))
-
--let make_class pub_meths class_init =
-+let make_class pub_meths class_init file pos =
- let table = create_table pub_meths in
- let env_init = class_init table in
-- init_class table;
-+ init_class_shared table file pos;
- (env_init (Obj.repr 0), class_init, env_init, Obj.repr 0)
-
-+let make_class_env pub_meths class_init file pos =
-+ let table = create_table pub_meths in
-+ let env_init = class_init table in
-+ init_class_shared table file pos;
-+ (env_init, class_init)
-+
- type init_table = { mutable env_init: t; mutable class_init: table -> t }
-
- let make_class_store pub_meths class_init init_table =
-Index: stdlib/camlinternalOO.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.mli,v
-retrieving revision 1.9
-diff -u -r1.9 camlinternalOO.mli
---- stdlib/camlinternalOO.mli 25 Oct 2005 18:34:07 -0000 1.9
-+++ stdlib/camlinternalOO.mli 2 Feb 2006 05:08:56 -0000
-@@ -43,14 +43,20 @@
- val add_initializer : table -> (obj -> unit) -> unit
- val dummy_table : table
- val create_table : string array -> table
-+(* val create_table_variables :
-+ string array -> string array -> string array -> table *)
- val init_class : table -> unit
-+val init_class_shared : table -> string -> int -> unit
- val inherits :
- table -> string array -> string array -> string array ->
- (t * (table -> obj -> Obj.t) * t * obj) -> bool ->
- (Obj.t * int array * closure array)
- val make_class :
-- string array -> (table -> Obj.t -> t) ->
-+ string array -> (table -> Obj.t -> t) -> string -> int ->
- (t * (table -> Obj.t -> t) * (Obj.t -> t) * Obj.t)
-+val make_class_env :
-+ string array -> (table -> Obj.t -> t) -> string -> int ->
-+ (Obj.t -> t) * (table -> Obj.t -> t)
- type init_table
- val make_class_store :
- string array -> (table -> t) -> init_table -> unit
+++ /dev/null
-Index: typing/includemod.ml
-===================================================================
---- typing/includemod.ml (revision 11161)
-+++ typing/includemod.ml (working copy)
-@@ -19,7 +19,7 @@
- open Types
- open Typedtree
-
--type error =
-+type symptom =
- Missing_field of Ident.t
- | Value_descriptions of Ident.t * value_description * value_description
- | Type_declarations of Ident.t * type_declaration
-@@ -38,6 +38,10 @@
- Ctype.class_match_failure list
- | Unbound_modtype_path of Path.t
-
-+type pos =
-+ Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
-+type error = pos list * symptom
-+
- exception Error of error list
-
- (* All functions "blah env x1 x2" check that x1 is included in x2,
-@@ -46,51 +50,52 @@
-
- (* Inclusion between value descriptions *)
-
--let value_descriptions env subst id vd1 vd2 =
-+let value_descriptions env cxt subst id vd1 vd2 =
- let vd2 = Subst.value_description subst vd2 in
- try
- Includecore.value_descriptions env vd1 vd2
- with Includecore.Dont_match ->
-- raise(Error[Value_descriptions(id, vd1, vd2)])
-+ raise(Error[cxt, Value_descriptions(id, vd1, vd2)])
-
- (* Inclusion between type declarations *)
-
--let type_declarations env subst id decl1 decl2 =
-+let type_declarations env cxt subst id decl1 decl2 =
- let decl2 = Subst.type_declaration subst decl2 in
- let err = Includecore.type_declarations env id decl1 decl2 in
-- if err <> [] then raise(Error[Type_declarations(id, decl1, decl2, err)])
-+ if err <> [] then raise(Error[cxt, Type_declarations(id, decl1, decl2, err)])
-
- (* Inclusion between exception declarations *)
-
--let exception_declarations env subst id decl1 decl2 =
-+let exception_declarations env cxt subst id decl1 decl2 =
- let decl2 = Subst.exception_declaration subst decl2 in
- if Includecore.exception_declarations env decl1 decl2
- then ()
-- else raise(Error[Exception_declarations(id, decl1, decl2)])
-+ else raise(Error[cxt, Exception_declarations(id, decl1, decl2)])
-
- (* Inclusion between class declarations *)
-
--let class_type_declarations env subst id decl1 decl2 =
-+let class_type_declarations env cxt subst id decl1 decl2 =
- let decl2 = Subst.cltype_declaration subst decl2 in
- match Includeclass.class_type_declarations env decl1 decl2 with
- [] -> ()
-- | reason -> raise(Error[Class_type_declarations(id, decl1, decl2, reason)])
-+ | reason ->
-+ raise(Error[cxt, Class_type_declarations(id, decl1, decl2, reason)])
-
--let class_declarations env subst id decl1 decl2 =
-+let class_declarations env cxt subst id decl1 decl2 =
- let decl2 = Subst.class_declaration subst decl2 in
- match Includeclass.class_declarations env decl1 decl2 with
- [] -> ()
-- | reason -> raise(Error[Class_declarations(id, decl1, decl2, reason)])
-+ | reason -> raise(Error[cxt, Class_declarations(id, decl1, decl2, reason)])
-
- (* Expand a module type identifier when possible *)
-
- exception Dont_match
-
--let expand_module_path env path =
-+let expand_module_path env cxt path =
- try
- Env.find_modtype_expansion path env
- with Not_found ->
-- raise(Error[Unbound_modtype_path path])
-+ raise(Error[cxt, Unbound_modtype_path path])
-
- (* Extract name, kind and ident from a signature item *)
-
-@@ -128,28 +133,29 @@
- Return the restriction that transforms a value of the smaller type
- into a value of the bigger type. *)
-
--let rec modtypes env subst mty1 mty2 =
-+let rec modtypes env cxt subst mty1 mty2 =
- try
-- try_modtypes env subst mty1 mty2
-+ try_modtypes env cxt subst mty1 mty2
- with
- Dont_match ->
-- raise(Error[Module_types(mty1, Subst.modtype subst mty2)])
-+ raise(Error[cxt, Module_types(mty1, Subst.modtype subst mty2)])
- | Error reasons ->
-- raise(Error(Module_types(mty1, Subst.modtype subst mty2) :: reasons))
-+ raise(Error((cxt, Module_types(mty1, Subst.modtype subst mty2))
-+ :: reasons))
-
--and try_modtypes env subst mty1 mty2 =
-+and try_modtypes env cxt subst mty1 mty2 =
- match (mty1, mty2) with
- (_, Tmty_ident p2) ->
-- try_modtypes2 env mty1 (Subst.modtype subst mty2)
-+ try_modtypes2 env cxt mty1 (Subst.modtype subst mty2)
- | (Tmty_ident p1, _) ->
-- try_modtypes env subst (expand_module_path env p1) mty2
-+ try_modtypes env cxt subst (expand_module_path env cxt p1) mty2
- | (Tmty_signature sig1, Tmty_signature sig2) ->
-- signatures env subst sig1 sig2
-+ signatures env cxt subst sig1 sig2
- | (Tmty_functor(param1, arg1, res1), Tmty_functor(param2, arg2, res2)) ->
- let arg2' = Subst.modtype subst arg2 in
-- let cc_arg = modtypes env Subst.identity arg2' arg1 in
-+ let cc_arg = modtypes env (Arg param1::cxt) Subst.identity arg2' arg1 in
- let cc_res =
-- modtypes (Env.add_module param1 arg2' env)
-+ modtypes (Env.add_module param1 arg2' env) (Body param1::cxt)
- (Subst.add_module param2 (Pident param1) subst) res1 res2 in
- begin match (cc_arg, cc_res) with
- (Tcoerce_none, Tcoerce_none) -> Tcoerce_none
-@@ -158,19 +164,19 @@
- | (_, _) ->
- raise Dont_match
-
--and try_modtypes2 env mty1 mty2 =
-+and try_modtypes2 env cxt mty1 mty2 =
- (* mty2 is an identifier *)
- match (mty1, mty2) with
- (Tmty_ident p1, Tmty_ident p2) when Path.same p1 p2 ->
- Tcoerce_none
- | (_, Tmty_ident p2) ->
-- try_modtypes env Subst.identity mty1 (expand_module_path env p2)
-+ try_modtypes env cxt Subst.identity mty1 (expand_module_path env cxt p2)
- | (_, _) ->
- assert false
-
- (* Inclusion between signatures *)
-
--and signatures env subst sig1 sig2 =
-+and signatures env cxt subst sig1 sig2 =
- (* Environment used to check inclusion of components *)
- let new_env =
- Env.add_signature sig1 env in
-@@ -202,7 +208,7 @@
- let rec pair_components subst paired unpaired = function
- [] ->
- begin match unpaired with
-- [] -> signature_components new_env subst (List.rev paired)
-+ [] -> signature_components new_env cxt subst (List.rev paired)
- | _ -> raise(Error unpaired)
- end
- | item2 :: rem ->
-@@ -234,7 +240,7 @@
- ((item1, item2, pos1) :: paired) unpaired rem
- with Not_found ->
- let unpaired =
-- if report then Missing_field id2 :: unpaired else unpaired in
-+ if report then (cxt, Missing_field id2) :: unpaired else unpaired in
- pair_components subst paired unpaired rem
- end in
- (* Do the pairing and checking, and return the final coercion *)
-@@ -242,65 +248,67 @@
-
- (* Inclusion between signature components *)
-
--and signature_components env subst = function
-+and signature_components env cxt subst = function
- [] -> []
- | (Tsig_value(id1, valdecl1), Tsig_value(id2, valdecl2), pos) :: rem ->
-- let cc = value_descriptions env subst id1 valdecl1 valdecl2 in
-+ let cc = value_descriptions env cxt subst id1 valdecl1 valdecl2 in
- begin match valdecl2.val_kind with
-- Val_prim p -> signature_components env subst rem
-- | _ -> (pos, cc) :: signature_components env subst rem
-+ Val_prim p -> signature_components env cxt subst rem
-+ | _ -> (pos, cc) :: signature_components env cxt subst rem
- end
- | (Tsig_type(id1, tydecl1, _), Tsig_type(id2, tydecl2, _), pos) :: rem ->
-- type_declarations env subst id1 tydecl1 tydecl2;
-- signature_components env subst rem
-+ type_declarations env cxt subst id1 tydecl1 tydecl2;
-+ signature_components env cxt subst rem
- | (Tsig_exception(id1, excdecl1), Tsig_exception(id2, excdecl2), pos)
- :: rem ->
-- exception_declarations env subst id1 excdecl1 excdecl2;
-- (pos, Tcoerce_none) :: signature_components env subst rem
-+ exception_declarations env cxt subst id1 excdecl1 excdecl2;
-+ (pos, Tcoerce_none) :: signature_components env cxt subst rem
- | (Tsig_module(id1, mty1, _), Tsig_module(id2, mty2, _), pos) :: rem ->
- let cc =
-- modtypes env subst (Mtype.strengthen env mty1 (Pident id1)) mty2 in
-- (pos, cc) :: signature_components env subst rem
-+ modtypes env (Module id1::cxt) subst
-+ (Mtype.strengthen env mty1 (Pident id1)) mty2 in
-+ (pos, cc) :: signature_components env cxt subst rem
- | (Tsig_modtype(id1, info1), Tsig_modtype(id2, info2), pos) :: rem ->
-- modtype_infos env subst id1 info1 info2;
-- signature_components env subst rem
-+ modtype_infos env cxt subst id1 info1 info2;
-+ signature_components env cxt subst rem
- | (Tsig_class(id1, decl1, _), Tsig_class(id2, decl2, _), pos) :: rem ->
-- class_declarations env subst id1 decl1 decl2;
-- (pos, Tcoerce_none) :: signature_components env subst rem
-+ class_declarations env cxt subst id1 decl1 decl2;
-+ (pos, Tcoerce_none) :: signature_components env cxt subst rem
- | (Tsig_cltype(id1, info1, _), Tsig_cltype(id2, info2, _), pos) :: rem ->
-- class_type_declarations env subst id1 info1 info2;
-- signature_components env subst rem
-+ class_type_declarations env cxt subst id1 info1 info2;
-+ signature_components env cxt subst rem
- | _ ->
- assert false
-
- (* Inclusion between module type specifications *)
-
--and modtype_infos env subst id info1 info2 =
-+and modtype_infos env cxt subst id info1 info2 =
- let info2 = Subst.modtype_declaration subst info2 in
-+ let cxt' = Modtype id :: cxt in
- try
- match (info1, info2) with
- (Tmodtype_abstract, Tmodtype_abstract) -> ()
- | (Tmodtype_manifest mty1, Tmodtype_abstract) -> ()
- | (Tmodtype_manifest mty1, Tmodtype_manifest mty2) ->
-- check_modtype_equiv env mty1 mty2
-+ check_modtype_equiv env cxt' mty1 mty2
- | (Tmodtype_abstract, Tmodtype_manifest mty2) ->
-- check_modtype_equiv env (Tmty_ident(Pident id)) mty2
-+ check_modtype_equiv env cxt' (Tmty_ident(Pident id)) mty2
- with Error reasons ->
-- raise(Error(Modtype_infos(id, info1, info2) :: reasons))
-+ raise(Error((cxt, Modtype_infos(id, info1, info2)) :: reasons))
-
--and check_modtype_equiv env mty1 mty2 =
-+and check_modtype_equiv env cxt mty1 mty2 =
- match
-- (modtypes env Subst.identity mty1 mty2,
-- modtypes env Subst.identity mty2 mty1)
-+ (modtypes env cxt Subst.identity mty1 mty2,
-+ modtypes env cxt Subst.identity mty2 mty1)
- with
- (Tcoerce_none, Tcoerce_none) -> ()
-- | (_, _) -> raise(Error [Modtype_permutation])
-+ | (_, _) -> raise(Error [cxt, Modtype_permutation])
-
- (* Simplified inclusion check between module types (for Env) *)
-
- let check_modtype_inclusion env mty1 path1 mty2 =
- try
-- ignore(modtypes env Subst.identity
-+ ignore(modtypes env [] Subst.identity
- (Mtype.strengthen env mty1 path1) mty2)
- with Error reasons ->
- raise Not_found
-@@ -312,16 +320,16 @@
-
- let compunit impl_name impl_sig intf_name intf_sig =
- try
-- signatures Env.initial Subst.identity impl_sig intf_sig
-+ signatures Env.initial [] Subst.identity impl_sig intf_sig
- with Error reasons ->
-- raise(Error(Interface_mismatch(impl_name, intf_name) :: reasons))
-+ raise(Error(([], Interface_mismatch(impl_name, intf_name)) :: reasons))
-
--(* Hide the substitution parameter to the outside world *)
-+(* Hide the context and substitution parameters to the outside world *)
-
--let modtypes env mty1 mty2 = modtypes env Subst.identity mty1 mty2
--let signatures env sig1 sig2 = signatures env Subst.identity sig1 sig2
-+let modtypes env mty1 mty2 = modtypes env [] Subst.identity mty1 mty2
-+let signatures env sig1 sig2 = signatures env [] Subst.identity sig1 sig2
- let type_declarations env id decl1 decl2 =
-- type_declarations env Subst.identity id decl1 decl2
-+ type_declarations env [] Subst.identity id decl1 decl2
-
- (* Error report *)
-
-@@ -384,9 +392,62 @@
- | Unbound_modtype_path path ->
- fprintf ppf "Unbound module type %a" Printtyp.path path
-
--let report_error ppf = function
-- | [] -> ()
-- | err :: errs ->
-- let print_errs ppf errs =
-- List.iter (fun err -> fprintf ppf "@ %a" include_err err) errs in
-- fprintf ppf "@[<v>%a%a@]" include_err err print_errs errs
-+let rec context ppf = function
-+ Module id :: rem ->
-+ fprintf ppf "@[<2>module %a%a@]" ident id args rem
-+ | Modtype id :: rem ->
-+ fprintf ppf "@[<2>module type %a =@ %a@]" ident id context_mty rem
-+ | Body x :: rem ->
-+ fprintf ppf "functor (%a) ->@ %a" ident x context_mty rem
-+ | Arg x :: rem ->
-+ fprintf ppf "functor (%a : %a) -> ..." ident x context_mty rem
-+ | [] ->
-+ fprintf ppf "<here>"
-+and context_mty ppf = function
-+ (Module _ | Modtype _) :: _ as rem ->
-+ fprintf ppf "@[<2>sig@ %a@;<1 -2>end@]" context rem
-+ | cxt -> context ppf cxt
-+and args ppf = function
-+ Body x :: rem ->
-+ fprintf ppf "(%a)%a" ident x args rem
-+ | Arg x :: rem ->
-+ fprintf ppf "(%a :@ %a) : ..." ident x context_mty rem
-+ | cxt ->
-+ fprintf ppf " :@ %a" context_mty cxt
-+
-+let path_of_context = function
-+ Module id :: rem ->
-+ let rec subm path = function
-+ [] -> path
-+ | Module id :: rem -> subm (Pdot (path, Ident.name id, -1)) rem
-+ | _ -> assert false
-+ in subm (Pident id) rem
-+ | _ -> assert false
-+
-+let context ppf cxt =
-+ if cxt = [] then () else
-+ if List.for_all (function Module _ -> true | _ -> false) cxt then
-+ fprintf ppf "In module %a:@ " path (path_of_context cxt)
-+ else
-+ fprintf ppf "@[<hv 2>At position@ %a@]@ " context cxt
-+
-+let include_err ppf (cxt, err) =
-+ fprintf ppf "@[<v>%a%a@]" context (List.rev cxt) include_err err
-+
-+let max_size = 500
-+let buffer = String.create max_size
-+let is_big obj =
-+ try ignore (Marshal.to_buffer buffer 0 max_size obj []); false
-+ with _ -> true
-+
-+let report_error ppf errs =
-+ if errs = [] then () else
-+ let (errs , err) = split_last errs in
-+ let pe = ref true in
-+ let include_err' ppf err =
-+ if !Clflags.show_trace || not (is_big err) then
-+ fprintf ppf "%a@ " include_err err
-+ else if !pe then (fprintf ppf "...@ "; pe := false)
-+ in
-+ let print_errs ppf = List.iter (include_err' ppf) in
-+ fprintf ppf "@[<v>%a%a@]" print_errs errs include_err err
-Index: typing/includemod.mli
-===================================================================
---- typing/includemod.mli (revision 11161)
-+++ typing/includemod.mli (working copy)
-@@ -24,7 +24,7 @@
- val type_declarations:
- Env.t -> Ident.t -> type_declaration -> type_declaration -> unit
-
--type error =
-+type symptom =
- Missing_field of Ident.t
- | Value_descriptions of Ident.t * value_description * value_description
- | Type_declarations of Ident.t * type_declaration
-@@ -43,6 +43,10 @@
- Ctype.class_match_failure list
- | Unbound_modtype_path of Path.t
-
-+type pos =
-+ Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
-+type error = pos list * symptom
-+
- exception Error of error list
-
- val report_error: formatter -> error list -> unit
-Index: utils/clflags.ml
-===================================================================
---- utils/clflags.ml (revision 11161)
-+++ utils/clflags.ml (working copy)
-@@ -53,6 +53,7 @@
- and dllpaths = ref ([] : string list) (* -dllpath *)
- and make_package = ref false (* -pack *)
- and for_package = ref (None: string option) (* -for-pack *)
-+and show_trace = ref false (* -show-trace *)
- let dump_parsetree = ref false (* -dparsetree *)
- and dump_rawlambda = ref false (* -drawlambda *)
- and dump_lambda = ref false (* -dlambda *)
-Index: utils/clflags.mli
-===================================================================
---- utils/clflags.mli (revision 11161)
-+++ utils/clflags.mli (working copy)
-@@ -50,6 +50,7 @@
- val dllpaths : string list ref
- val make_package : bool ref
- val for_package : string option ref
-+val show_trace : bool ref
- val dump_parsetree : bool ref
- val dump_rawlambda : bool ref
- val dump_lambda : bool ref
+++ /dev/null
-Index: parsing/lexer.mll
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/parsing/lexer.mll,v
-retrieving revision 1.73
-diff -u -r1.73 lexer.mll
---- parsing/lexer.mll 11 Apr 2005 16:44:26 -0000 1.73
-+++ parsing/lexer.mll 2 Feb 2006 06:28:32 -0000
-@@ -63,6 +63,8 @@
- "match", MATCH;
- "method", METHOD;
- "module", MODULE;
-+ "multifun", MULTIFUN;
-+ "multimatch", MULTIMATCH;
- "mutable", MUTABLE;
- "new", NEW;
- "object", OBJECT;
-Index: parsing/parser.mly
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/parsing/parser.mly,v
-retrieving revision 1.123
-diff -u -r1.123 parser.mly
---- parsing/parser.mly 23 Mar 2005 03:08:37 -0000 1.123
-+++ parsing/parser.mly 2 Feb 2006 06:28:32 -0000
-@@ -257,6 +257,8 @@
- %token MINUSDOT
- %token MINUSGREATER
- %token MODULE
-+%token MULTIFUN
-+%token MULTIMATCH
- %token MUTABLE
- %token <nativeint> NATIVEINT
- %token NEW
-@@ -325,7 +327,7 @@
- %nonassoc SEMI /* below EQUAL ({lbl=...; lbl=...}) */
- %nonassoc LET /* above SEMI ( ...; let ... in ...) */
- %nonassoc below_WITH
--%nonassoc FUNCTION WITH /* below BAR (match ... with ...) */
-+%nonassoc FUNCTION WITH MULTIFUN /* below BAR (match ... with ...) */
- %nonassoc AND /* above WITH (module rec A: SIG with ... and ...) */
- %nonassoc THEN /* below ELSE (if ... then ...) */
- %nonassoc ELSE /* (if ... then ... else ...) */
-@@ -804,8 +806,12 @@
- { mkexp(Pexp_function("", None, List.rev $3)) }
- | FUN labeled_simple_pattern fun_def
- { let (l,o,p) = $2 in mkexp(Pexp_function(l, o, [p, $3])) }
-+ | MULTIFUN opt_bar match_cases
-+ { mkexp(Pexp_multifun(List.rev $3)) }
- | MATCH seq_expr WITH opt_bar match_cases
-- { mkexp(Pexp_match($2, List.rev $5)) }
-+ { mkexp(Pexp_match($2, List.rev $5, false)) }
-+ | MULTIMATCH seq_expr WITH opt_bar match_cases
-+ { mkexp(Pexp_match($2, List.rev $5, true)) }
- | TRY seq_expr WITH opt_bar match_cases
- { mkexp(Pexp_try($2, List.rev $5)) }
- | TRY seq_expr WITH error
-@@ -1318,10 +1324,10 @@
- | simple_core_type2 { Rinherit $1 }
- ;
- tag_field:
-- name_tag OF opt_ampersand amper_type_list
-- { Rtag ($1, $3, List.rev $4) }
-- | name_tag
-- { Rtag ($1, true, []) }
-+ name_tag OF opt_ampersand amper_type_list amper_type_pair_list
-+ { Rtag ($1, $3, List.rev $4, $5) }
-+ | name_tag amper_type_pair_list
-+ { Rtag ($1, true, [], $2) }
- ;
- opt_ampersand:
- AMPERSAND { true }
-@@ -1331,6 +1337,11 @@
- core_type { [$1] }
- | amper_type_list AMPERSAND core_type { $3 :: $1 }
- ;
-+amper_type_pair_list:
-+ AMPERSAND core_type EQUAL core_type amper_type_pair_list
-+ { ($2, $4) :: $5 }
-+ | /* empty */
-+ { [] }
- opt_present:
- LBRACKETGREATER name_tag_list RBRACKET { List.rev $2 }
- | /* empty */ { [] }
-Index: parsing/parsetree.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/parsing/parsetree.mli,v
-retrieving revision 1.42
-diff -u -r1.42 parsetree.mli
---- parsing/parsetree.mli 23 Mar 2005 03:08:37 -0000 1.42
-+++ parsing/parsetree.mli 2 Feb 2006 06:28:32 -0000
-@@ -43,7 +43,7 @@
- | Pfield_var
-
- and row_field =
-- Rtag of label * bool * core_type list
-+ Rtag of label * bool * core_type list * (core_type * core_type) list
- | Rinherit of core_type
-
- (* XXX Type expressions for the class language *)
-@@ -86,7 +86,7 @@
- | Pexp_let of rec_flag * (pattern * expression) list * expression
- | Pexp_function of label * expression option * (pattern * expression) list
- | Pexp_apply of expression * (label * expression) list
-- | Pexp_match of expression * (pattern * expression) list
-+ | Pexp_match of expression * (pattern * expression) list * bool
- | Pexp_try of expression * (pattern * expression) list
- | Pexp_tuple of expression list
- | Pexp_construct of Longident.t * expression option * bool
-@@ -111,6 +111,7 @@
- | Pexp_lazy of expression
- | Pexp_poly of expression * core_type option
- | Pexp_object of class_structure
-+ | Pexp_multifun of (pattern * expression) list
-
- (* Value descriptions *)
-
-Index: parsing/printast.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/parsing/printast.ml,v
-retrieving revision 1.29
-diff -u -r1.29 printast.ml
---- parsing/printast.ml 4 Jan 2006 16:55:50 -0000 1.29
-+++ parsing/printast.ml 2 Feb 2006 06:28:32 -0000
-@@ -205,10 +205,14 @@
- line i ppf "Pexp_apply\n";
- expression i ppf e;
- list i label_x_expression ppf l;
-- | Pexp_match (e, l) ->
-+ | Pexp_match (e, l, b) ->
- line i ppf "Pexp_match\n";
- expression i ppf e;
- list i pattern_x_expression_case ppf l;
-+ bool i ppf b
-+ | Pexp_multifun l ->
-+ line i ppf "Pexp_multifun\n";
-+ list i pattern_x_expression_case ppf l;
- | Pexp_try (e, l) ->
- line i ppf "Pexp_try\n";
- expression i ppf e;
-@@ -653,7 +657,7 @@
-
- and label_x_bool_x_core_type_list i ppf x =
- match x with
-- Rtag (l, b, ctl) ->
-+ Rtag (l, b, ctl, cstr) ->
- line i ppf "Rtag \"%s\" %s\n" l (string_of_bool b);
- list (i+1) core_type ppf ctl
- | Rinherit (ct) ->
-Index: typing/btype.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/btype.ml,v
-retrieving revision 1.38
-diff -u -r1.38 btype.ml
---- typing/btype.ml 4 Jan 2006 16:55:50 -0000 1.38
-+++ typing/btype.ml 2 Feb 2006 06:28:32 -0000
-@@ -66,16 +66,16 @@
- Clink r when !r <> Cunknown -> commu_repr !r
- | c -> c
-
--let rec row_field_repr_aux tl = function
-- Reither(_, tl', _, {contents = Some fi}) ->
-- row_field_repr_aux (tl@tl') fi
-- | Reither(c, tl', m, r) ->
-- Reither(c, tl@tl', m, r)
-+let rec row_field_repr_aux tl tl2 = function
-+ Reither(_, tl', _, tl2', {contents = Some fi}) ->
-+ row_field_repr_aux (tl@tl') (tl2@tl2') fi
-+ | Reither(c, tl', m, tl2', r) ->
-+ Reither(c, tl@tl', m, tl2@tl2', r)
- | Rpresent (Some _) when tl <> [] ->
- Rpresent (Some (List.hd tl))
- | fi -> fi
-
--let row_field_repr fi = row_field_repr_aux [] fi
-+let row_field_repr fi = row_field_repr_aux [] [] fi
-
- let rec rev_concat l ll =
- match ll with
-@@ -170,7 +170,8 @@
- (fun (_, fi) ->
- match row_field_repr fi with
- | Rpresent(Some ty) -> f ty
-- | Reither(_, tl, _, _) -> List.iter f tl
-+ | Reither(_, tl, _, tl2, _) ->
-+ List.iter f tl; List.iter (fun (t1,t2) -> f t1; f t2) tl2
- | _ -> ())
- row.row_fields;
- match (repr row.row_more).desc with
-@@ -208,15 +209,17 @@
- (fun (l, fi) -> l,
- match row_field_repr fi with
- | Rpresent(Some ty) -> Rpresent(Some(f ty))
-- | Reither(c, tl, m, e) ->
-+ | Reither(c, tl, m, tpl, e) ->
- let e = if keep then e else ref None in
- let m = if row.row_fixed then fixed else m in
- let tl = List.map f tl in
-+ let tl1 = List.map (fun (t1,_) -> repr (f t1)) tpl
-+ and tl2 = List.map (fun (_,t2) -> repr (f t2)) tpl in
- bound := List.filter
- (function {desc=Tconstr(_,[],_)} -> false | _ -> true)
-- (List.map repr tl)
-+ (List.map repr tl @ tl1 @ tl2)
- @ !bound;
-- Reither(c, tl, m, e)
-+ Reither(c, tl, m, List.combine tl1 tl2, e)
- | _ -> fi)
- row.row_fields in
- let name =
-Index: typing/ctype.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v
-retrieving revision 1.200
-diff -u -r1.200 ctype.ml
---- typing/ctype.ml 6 Jan 2006 02:16:24 -0000 1.200
-+++ typing/ctype.ml 2 Feb 2006 06:28:32 -0000
-@@ -340,7 +340,7 @@
- let fi = filter_row_fields erase fi in
- match row_field_repr f with
- Rabsent -> fi
-- | Reither(_,_,false,e) when erase -> set_row_field e Rabsent; fi
-+ | Reither(_,_,false,_,e) when erase -> set_row_field e Rabsent; fi
- | _ -> p :: fi
-
- (**************************************)
-@@ -1286,6 +1286,10 @@
-
- module TypeMap = Map.Make (TypeOps)
-
-+
-+(* A list of univars which may appear free in a type, but only if generic *)
-+let allowed_univars = ref TypeSet.empty
-+
- (* Test the occurence of free univars in a type *)
- (* that's way too expansive. Must do some kind of cacheing *)
- let occur_univar env ty =
-@@ -1307,7 +1311,12 @@
- then
- match ty.desc with
- Tunivar ->
-- if not (TypeSet.mem ty bound) then raise (Unify [ty, newgenvar()])
-+ if TypeSet.mem ty bound then () else
-+ if TypeSet.mem ty !allowed_univars &&
-+ (ty.level = generic_level ||
-+ ty.level = pivot_level - generic_level)
-+ then ()
-+ else raise (Unify [ty, newgenvar()])
- | Tpoly (ty, tyl) ->
- let bound = List.fold_right TypeSet.add (List.map repr tyl) bound in
- occur_rec bound ty
-@@ -1393,6 +1402,7 @@
- with exn -> univar_pairs := old_univars; raise exn
-
- let univar_pairs = ref []
-+let delayed_conditionals = ref []
-
-
- (*****************)
-@@ -1691,9 +1701,11 @@
- with Not_found -> (h,l)::hl)
- (List.map (fun (l,_) -> (hash_variant l, l)) row1.row_fields)
- (List.map fst r2));
-+ let fixed1 = row1.row_fixed || rm1.desc <> Tvar
-+ and fixed2 = row2.row_fixed || rm2.desc <> Tvar in
- let more =
-- if row1.row_fixed then rm1 else
-- if row2.row_fixed then rm2 else
-+ if fixed1 then rm1 else
-+ if fixed2 then rm2 else
- newgenvar ()
- in update_level env (min rm1.level rm2.level) more;
- let fixed = row1.row_fixed || row2.row_fixed
-@@ -1726,18 +1738,18 @@
- let bound = row1.row_bound @ row2.row_bound in
- let row0 = {row_fields = []; row_more = more; row_bound = bound;
- row_closed = closed; row_fixed = fixed; row_name = name} in
-- let set_more row rest =
-+ let set_more row row_fixed rest =
- let rest =
- if closed then
- filter_row_fields row.row_closed rest
- else rest in
-- if rest <> [] && (row.row_closed || row.row_fixed)
-- || closed && row.row_fixed && not row.row_closed then begin
-+ if rest <> [] && (row.row_closed || row_fixed)
-+ || closed && row_fixed && not row.row_closed then begin
- let t1 = mkvariant [] true and t2 = mkvariant rest false in
- raise (Unify [if row == row1 then (t1,t2) else (t2,t1)])
- end;
- let rm = row_more row in
-- if row.row_fixed then
-+ if row_fixed then
- if row0.row_more == rm then () else
- if rm.desc = Tvar then link_type rm row0.row_more else
- unify env rm row0.row_more
-@@ -1748,11 +1760,11 @@
- in
- let md1 = rm1.desc and md2 = rm2.desc in
- begin try
-- set_more row1 r2;
-- set_more row2 r1;
-+ set_more row1 fixed1 r2;
-+ set_more row2 fixed2 r1;
- List.iter
- (fun (l,f1,f2) ->
-- try unify_row_field env row1.row_fixed row2.row_fixed l f1 f2
-+ try unify_row_field env fixed1 fixed2 row1 row2 l f1 f2
- with Unify trace ->
- raise (Unify ((mkvariant [l,f1] true,
- mkvariant [l,f2] true) :: trace)))
-@@ -1761,13 +1773,13 @@
- log_type rm1; rm1.desc <- md1; log_type rm2; rm2.desc <- md2; raise exn
- end
-
--and unify_row_field env fixed1 fixed2 l f1 f2 =
-+and unify_row_field env fixed1 fixed2 row1 row2 l f1 f2 =
- let f1 = row_field_repr f1 and f2 = row_field_repr f2 in
- if f1 == f2 then () else
- match f1, f2 with
- Rpresent(Some t1), Rpresent(Some t2) -> unify env t1 t2
- | Rpresent None, Rpresent None -> ()
-- | Reither(c1, tl1, m1, e1), Reither(c2, tl2, m2, e2) ->
-+ | Reither(c1, tl1, m1, tp1, e1), Reither(c2, tl2, m2, tp2, e2) ->
- if e1 == e2 then () else
- let redo =
- (m1 || m2) &&
-@@ -1777,32 +1789,70 @@
- List.iter (unify env t1) tl;
- !e1 <> None || !e2 <> None
- end in
-- if redo then unify_row_field env fixed1 fixed2 l f1 f2 else
-+ let redo =
-+ redo || begin
-+ if tp1 = [] && fixed1 then unify_pairs env tp2;
-+ if tp2 = [] && fixed2 then unify_pairs env tp1;
-+ !e1 <> None || !e2 <> None
-+ end
-+ in
-+ if redo then unify_row_field env fixed1 fixed2 row1 row2 l f1 f2 else
- let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in
- let rec remq tl = function [] -> []
- | ty :: tl' ->
- if List.memq ty tl then remq tl tl' else ty :: remq tl tl'
- in
- let tl2' = remq tl2 tl1 and tl1' = remq tl1 tl2 in
-+ let repr_pairs = List.map (fun (t1,t2) -> repr t1, repr t2) in
-+ let tp1 = repr_pairs tp1 and tp2 = repr_pairs tp2 in
-+ let rec rempq tp = function [] -> []
-+ | (t1,t2 as p) :: tp' ->
-+ if List.exists (fun (t1',t2') -> t1==t1' && t2==t2') (tp@tp') then
-+ rempq tp tp'
-+ else p :: rempq tp tp'
-+ in
-+ let tp1' =
-+ if fixed2 then begin
-+ delayed_conditionals :=
-+ (!univar_pairs, tp1, l, row2) :: !delayed_conditionals;
-+ []
-+ end else rempq tp2 tp1
-+ and tp2' =
-+ if fixed1 then begin
-+ delayed_conditionals :=
-+ (!univar_pairs, tp2, l, row1) :: !delayed_conditionals;
-+ []
-+ end else rempq tp1 tp2
-+ in
- let e = ref None in
-- let f1' = Reither(c1 || c2, tl1', m1 || m2, e)
-- and f2' = Reither(c1 || c2, tl2', m1 || m2, e) in
-- set_row_field e1 f1'; set_row_field e2 f2';
-- | Reither(_, _, false, e1), Rabsent -> set_row_field e1 f2
-- | Rabsent, Reither(_, _, false, e2) -> set_row_field e2 f1
-+ let f1' = Reither(c1 || c2, tl1', m1 || m2, tp2', e)
-+ and f2' = Reither(c1 || c2, tl2', m1 || m2, tp1', e) in
-+ set_row_field e1 f1'; set_row_field e2 f2'
-+ | Reither(_, _, false, _, e1), Rabsent -> set_row_field e1 f2
-+ | Rabsent, Reither(_, _, false, _, e2) -> set_row_field e2 f1
- | Rabsent, Rabsent -> ()
-- | Reither(false, tl, _, e1), Rpresent(Some t2) when not fixed1 ->
-+ | Reither(false, tl, _, tp, e1), Rpresent(Some t2) when not fixed1 ->
- set_row_field e1 f2;
-- (try List.iter (fun t1 -> unify env t1 t2) tl
-+ begin try
-+ List.iter (fun t1 -> unify env t1 t2) tl;
-+ List.iter (fun (t1,t2) -> unify env t1 t2) tp
-+ with exn -> e1 := None; raise exn
-+ end
-+ | Rpresent(Some t1), Reither(false, tl, _, tp, e2) when not fixed2 ->
-+ set_row_field e2 f1;
-+ begin try
-+ List.iter (unify env t1) tl;
-+ List.iter (fun (t1,t2) -> unify env t1 t2) tp
-+ with exn -> e2 := None; raise exn
-+ end
-+ | Reither(true, [], _, tpl, e1), Rpresent None when not fixed1 ->
-+ set_row_field e1 f2;
-+ (try List.iter (fun (t1,t2) -> unify env t1 t2) tpl
- with exn -> e1 := None; raise exn)
-- | Rpresent(Some t1), Reither(false, tl, _, e2) when not fixed2 ->
-+ | Rpresent None, Reither(true, [], _, tpl, e2) when not fixed2 ->
- set_row_field e2 f1;
-- (try List.iter (unify env t1) tl
-+ (try List.iter (fun (t1,t2) -> unify env t1 t2) tpl
- with exn -> e2 := None; raise exn)
-- | Reither(true, [], _, e1), Rpresent None when not fixed1 ->
-- set_row_field e1 f2
-- | Rpresent None, Reither(true, [], _, e2) when not fixed2 ->
-- set_row_field e2 f1
- | _ -> raise (Unify [])
-
-
-@@ -1920,6 +1970,166 @@
- (* Matching between type schemes *)
- (***********************************)
-
-+(* Forward declaration (order should be reversed...) *)
-+let equal' = ref (fun _ -> failwith "Ctype.equal'")
-+
-+let make_generics_univars tyl =
-+ let polyvars = ref TypeSet.empty in
-+ let rec make_rec ty =
-+ let ty = repr ty in
-+ if ty.level = generic_level then begin
-+ if ty.desc = Tvar then begin
-+ log_type ty;
-+ ty.desc <- Tunivar;
-+ polyvars := TypeSet.add ty !polyvars
-+ end
-+ else if ty.desc = Tunivar then set_level ty (generic_level - 1);
-+ ty.level <- pivot_level - generic_level;
-+ iter_type_expr make_rec ty
-+ end
-+ in
-+ List.iter make_rec tyl;
-+ List.iter unmark_type tyl;
-+ !polyvars
-+
-+(* New version of moregeneral, using unification *)
-+
-+let copy_cond (p,tpl,l,row) =
-+ let row =
-+ match repr (copy (newgenty (Tvariant row))) with
-+ {desc=Tvariant row} -> row
-+ | _ -> assert false
-+ and pairs =
-+ List.map (fun (t1,t2) -> copy t1, copy t2) tpl in
-+ (p, pairs, l, row)
-+
-+let get_row_field l row =
-+ try row_field_repr (List.assoc l (row_repr row).row_fields)
-+ with Not_found -> Rabsent
-+
-+let rec check_conditional_list env cdtls pattvars tpls =
-+ match cdtls with
-+ [] ->
-+ let finished =
-+ List.for_all (fun (_,t1,t2) -> !equal' env false [t1] [t2]) tpls in
-+ if not finished then begin
-+ let polyvars = make_generics_univars pattvars in
-+ delayed_conditionals := [];
-+ allowed_univars := polyvars;
-+ List.iter (fun (pairs, ty1, ty2) -> unify_pairs env ty1 ty2 pairs)
-+ tpls;
-+ check_conditionals env polyvars !delayed_conditionals
-+ end
-+ | (pairs, tpl1, l, row2 as cond) :: cdtls ->
-+ let cont = check_conditional_list env cdtls pattvars in
-+ let tpl1 =
-+ List.filter (fun (t1,t2) -> not (!equal' env false [t1] [t2])) tpl1 in
-+ let included =
-+ List.for_all
-+ (fun (t1,t2) ->
-+ List.exists
-+ (fun (_,t1',t2') -> !equal' env false [t1;t2] [t1';t2'])
-+ tpls)
-+ tpl1 in
-+ if included then cont tpls else
-+ match get_row_field l row2 with
-+ Rpresent _ ->
-+ cont (List.map (fun (t1,t2) -> (pairs,t1,t2)) tpl1 @ tpls)
-+ | Rabsent -> cont tpls
-+ | Reither (c, tl2, _, _, _) ->
-+ cont tpls;
-+ if c && tl2 <> [] then () (* cannot succeed *) else
-+ let (pairs, tpl1, l, row2) = copy_cond cond
-+ and tpls = List.map (fun (p,t1,t2) -> p, copy t1, copy t2) tpls
-+ and pattvars = List.map copy pattvars
-+ and cdtls = List.map copy_cond cdtls in
-+ cleanup_types ();
-+ let tl2, tpl2, e2 =
-+ match get_row_field l row2 with
-+ Reither (c, tl2, _, tpl2, e2) -> tl2, tpl2, e2
-+ | _ -> assert false
-+ in
-+ let snap = Btype.snapshot () in
-+ let ok =
-+ try
-+ begin match tl2 with
-+ [] ->
-+ set_row_field e2 (Rpresent None)
-+ | t::tl ->
-+ set_row_field e2 (Rpresent (Some t));
-+ List.iter (unify env t) tl
-+ end;
-+ List.iter (fun (t1,t2) -> unify_pairs env t1 t2 pairs) tpl2;
-+ true
-+ with exn ->
-+ Btype.backtrack snap;
-+ false
-+ in
-+ (* This is not [cont] : types have been copied *)
-+ if ok then
-+ check_conditional_list env cdtls pattvars
-+ (List.map (fun (t1,t2) -> (pairs,t1,t2)) tpl1 @ tpls)
-+
-+and check_conditionals env polyvars cdtls =
-+ let cdtls = List.map copy_cond cdtls in
-+ let pattvars = ref [] in
-+ TypeSet.iter
-+ (fun ty ->
-+ let ty = repr ty in
-+ match ty.desc with
-+ Tsubst ty ->
-+ let ty = repr ty in
-+ begin match ty.desc with
-+ Tunivar ->
-+ log_type ty;
-+ ty.desc <- Tvar;
-+ pattvars := ty :: !pattvars
-+ | Ttuple [tv;_] ->
-+ if tv.desc = Tunivar then
-+ (log_type tv; tv.desc <- Tvar; pattvars := ty :: !pattvars)
-+ else if tv.desc <> Tvar then assert false
-+ | Tvar -> ()
-+ | _ -> assert false
-+ end
-+ | _ -> ())
-+ polyvars;
-+ cleanup_types ();
-+ check_conditional_list env cdtls !pattvars []
-+
-+
-+(* Must empty univar_pairs first *)
-+let unify_poly env polyvars subj patt =
-+ let old_level = !current_level in
-+ current_level := generic_level;
-+ delayed_conditionals := [];
-+ allowed_univars := polyvars;
-+ try
-+ unify env subj patt;
-+ check_conditionals env polyvars !delayed_conditionals;
-+ current_level := old_level;
-+ allowed_univars := TypeSet.empty;
-+ delayed_conditionals := []
-+ with exn ->
-+ current_level := old_level;
-+ allowed_univars := TypeSet.empty;
-+ delayed_conditionals := [];
-+ raise exn
-+
-+let moregeneral env _ subj patt =
-+ let old_level = !current_level in
-+ current_level := generic_level;
-+ let subj = instance subj
-+ and patt = instance patt in
-+ let polyvars = make_generics_univars [patt] in
-+ current_level := old_level;
-+ let snap = Btype.snapshot () in
-+ try
-+ unify_poly env polyvars subj patt;
-+ true
-+ with Unify _ ->
-+ Btype.backtrack snap;
-+ false
-+
- (*
- Update the level of [ty]. First check that the levels of generic
- variables from the subject are not lowered.
-@@ -2072,35 +2282,101 @@
- Rpresent(Some t1), Rpresent(Some t2) ->
- moregen inst_nongen type_pairs env t1 t2
- | Rpresent None, Rpresent None -> ()
-- | Reither(false, tl1, _, e1), Rpresent(Some t2) when not univ ->
-+ | Reither(false, tl1, _, [], e1), Rpresent(Some t2) when not univ ->
- set_row_field e1 f2;
- List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2) tl1
-- | Reither(c1, tl1, _, e1), Reither(c2, tl2, m2, e2) ->
-+ | Reither(c1, tl1, _, tpl1, e1), Reither(c2, tl2, m2, tpl2, e2) ->
- if e1 != e2 then begin
- if c1 && not c2 then raise(Unify []);
-- set_row_field e1 (Reither (c2, [], m2, e2));
-- if List.length tl1 = List.length tl2 then
-- List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2
-- else match tl2 with
-- t2 :: _ ->
-+ let tpl' = if tpl1 = [] then tpl2 else [] in
-+ set_row_field e1 (Reither (c2, [], m2, tpl', e2));
-+ begin match tl2 with
-+ [t2] ->
- List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2)
- tl1
-- | [] ->
-- if tl1 <> [] then raise (Unify [])
-+ | _ ->
-+ if List.length tl1 <> List.length tl2 then raise (Unify []);
-+ List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2
-+ end;
-+ if tpl1 <> [] then
-+ delayed_conditionals :=
-+ (!univar_pairs, tpl1, l, row2) :: !delayed_conditionals
- end
-- | Reither(true, [], _, e1), Rpresent None when not univ ->
-+ | Reither(true, [], _, [], e1), Rpresent None when not univ ->
- set_row_field e1 f2
-- | Reither(_, _, _, e1), Rabsent when not univ ->
-+ | Reither(_, _, _, [], e1), Rabsent when not univ ->
- set_row_field e1 f2
- | Rabsent, Rabsent -> ()
- | _ -> raise (Unify []))
- pairs
-
-+let check_conditional env (pairs, tpl1, l, row2) tpls cont =
-+ let tpl1 =
-+ List.filter (fun (t1,t2) -> not (!equal' env false [t1] [t2])) tpl1 in
-+ let included =
-+ List.for_all
-+ (fun (t1,t2) ->
-+ List.exists (fun (t1',t2') -> !equal' env false [t1;t2] [t1';t2'])
-+ tpls)
-+ tpl1 in
-+ if tpl1 = [] || included then cont tpls else
-+ match get_row_field l row2 with
-+ Rpresent _ -> cont (tpl1 @ tpls)
-+ | Rabsent -> cont tpls
-+ | Reither (c, tl2, _, tpl2, e2) ->
-+ if not c || tl2 = [] then begin
-+ let snap = Btype.snapshot () in
-+ let ok =
-+ try
-+ begin match tl2 with
-+ [] ->
-+ set_row_field e2 (Rpresent None)
-+ | t::tl ->
-+ set_row_field e2 (Rpresent (Some t));
-+ List.iter (unify env t) tl
-+ end;
-+ List.iter (fun (t1,t2) -> unify_pairs env t1 t2 pairs) tpl2;
-+ true
-+ with Unify _ -> false
-+ in
-+ if ok then cont (tpl1 @ tpls);
-+ Btype.backtrack snap
-+ end;
-+ cont tpls
-+
-+let rec check_conditionals inst_nongen env cdtls tpls =
-+ match cdtls with
-+ [] ->
-+ let tpls =
-+ List.filter (fun (t1,t2) -> not (!equal' env false [t1] [t2])) tpls in
-+ if tpls = [] then () else begin
-+ delayed_conditionals := [];
-+ let tl1, tl2 = List.split tpls in
-+ let type_pairs = TypePairs.create 13 in
-+ List.iter2 (moregen false type_pairs env) tl2 tl1;
-+ check_conditionals inst_nongen env !delayed_conditionals []
-+ end
-+ | cdtl :: cdtls ->
-+ check_conditional env cdtl tpls
-+ (check_conditionals inst_nongen env cdtls)
-+
-+
- (* Must empty univar_pairs first *)
- let moregen inst_nongen type_pairs env patt subj =
- univar_pairs := [];
-- moregen inst_nongen type_pairs env patt subj
-+ delayed_conditionals := [];
-+ try
-+ moregen inst_nongen type_pairs env patt subj;
-+ check_conditionals inst_nongen env !delayed_conditionals [];
-+ univar_pairs := [];
-+ delayed_conditionals := []
-+ with exn ->
-+ univar_pairs := [];
-+ delayed_conditionals := [];
-+ raise exn
-+
-
-+(* old implementation
- (*
- Non-generic variable can be instanciated only if [inst_nongen] is
- true. So, [inst_nongen] should be set to false if the subject might
-@@ -2128,6 +2404,7 @@
- in
- current_level := old_level;
- res
-+*)
-
-
- (* Alternative approach: "rigidify" a type scheme,
-@@ -2296,30 +2573,36 @@
- {desc=Tvariant row2} -> eqtype_row rename type_pairs subst env row1 row2
- | _ -> raise Cannot_expand
- with Cannot_expand ->
-+ let eqtype_rec = eqtype rename type_pairs subst env in
- let row1 = row_repr row1 and row2 = row_repr row2 in
- let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
- if row1.row_closed <> row2.row_closed
- || not row1.row_closed && (r1 <> [] || r2 <> [])
- || filter_row_fields false (r1 @ r2) <> []
- then raise (Unify []);
-- if not (static_row row1) then
-- eqtype rename type_pairs subst env row1.row_more row2.row_more;
-+ if not (static_row row1) then eqtype_rec row1.row_more row2.row_more;
- List.iter
- (fun (_,f1,f2) ->
- match row_field_repr f1, row_field_repr f2 with
- Rpresent(Some t1), Rpresent(Some t2) ->
-- eqtype rename type_pairs subst env t1 t2
-- | Reither(true, [], _, _), Reither(true, [], _, _) ->
-- ()
-- | Reither(false, t1::tl1, _, _), Reither(false, t2::tl2, _, _) ->
-- eqtype rename type_pairs subst env t1 t2;
-+ eqtype_rec t1 t2
-+ | Reither(true, [], _, tp1, _), Reither(true, [], _, tp2, _) ->
-+ List.iter2
-+ (fun (t1,t1') (t2,t2') -> eqtype_rec t1 t2; eqtype_rec t1' t2')
-+ tp1 tp2
-+ | Reither(false, t1::tl1, _, tpl1, _),
-+ Reither(false, t2::tl2, _, tpl2, _) ->
-+ eqtype_rec t1 t2;
-+ List.iter2
-+ (fun (t1,t1') (t2,t2') -> eqtype_rec t1 t2; eqtype_rec t1' t2')
-+ tpl1 tpl2;
- if List.length tl1 = List.length tl2 then
- (* if same length allow different types (meaning?) *)
-- List.iter2 (eqtype rename type_pairs subst env) tl1 tl2
-+ List.iter2 eqtype_rec tl1 tl2
- else begin
- (* otherwise everything must be equal *)
-- List.iter (eqtype rename type_pairs subst env t1) tl2;
-- List.iter (fun t1 -> eqtype rename type_pairs subst env t1 t2) tl1
-+ List.iter (eqtype_rec t1) tl2;
-+ List.iter (fun t1 -> eqtype_rec t1 t2) tl1
- end
- | Rpresent None, Rpresent None -> ()
- | Rabsent, Rabsent -> ()
-@@ -2334,6 +2617,8 @@
- with
- Unify _ -> false
-
-+let () = equal' := equal
-+
- (* Must empty univar_pairs first *)
- let eqtype rename type_pairs subst env t1 t2 =
- univar_pairs := [];
-@@ -2770,14 +3055,14 @@
- (fun (l,f as orig) -> match row_field_repr f with
- Rpresent None ->
- if posi then
-- (l, Reither(true, [], false, ref None)), Unchanged
-+ (l, Reither(true, [], false, [], ref None)), Unchanged
- else
- orig, Unchanged
- | Rpresent(Some t) ->
- let (t', c) = build_subtype env visited loops posi level' t in
- if posi && level > 0 then begin
- bound := t' :: !bound;
-- (l, Reither(false, [t'], false, ref None)), c
-+ (l, Reither(false, [t'], false, [], ref None)), c
- end else
- (l, Rpresent(Some t')), c
- | _ -> assert false)
-@@ -2960,11 +3245,11 @@
- List.fold_left
- (fun cstrs (_,f1,f2) ->
- match row_field_repr f1, row_field_repr f2 with
-- (Rpresent None|Reither(true,_,_,_)), Rpresent None ->
-+ (Rpresent None|Reither(true,_,_,[],_)), Rpresent None ->
- cstrs
- | Rpresent(Some t1), Rpresent(Some t2) ->
- subtype_rec env ((t1, t2)::trace) t1 t2 cstrs
-- | Reither(false, t1::_, _, _), Rpresent(Some t2) ->
-+ | Reither(false, t1::_, _, [], _), Rpresent(Some t2) ->
- subtype_rec env ((t1, t2)::trace) t1 t2 cstrs
- | Rabsent, _ -> cstrs
- | _ -> raise Exit)
-@@ -2977,11 +3262,11 @@
- (fun cstrs (_,f1,f2) ->
- match row_field_repr f1, row_field_repr f2 with
- Rpresent None, Rpresent None
-- | Reither(true,[],_,_), Reither(true,[],_,_)
-+ | Reither(true,[],_,[],_), Reither(true,[],_,[],_)
- | Rabsent, Rabsent ->
- cstrs
- | Rpresent(Some t1), Rpresent(Some t2)
-- | Reither(false,[t1],_,_), Reither(false,[t2],_,_) ->
-+ | Reither(false,[t1],_,[],_), Reither(false,[t2],_,[],_) ->
- subtype_rec env ((t1, t2)::trace) t1 t2 cstrs
- | _ -> raise Exit)
- cstrs pairs
-@@ -3079,16 +3364,26 @@
- let fields = List.map
- (fun (l,f) ->
- let f = row_field_repr f in l,
-- match f with Reither(b, ty::(_::_ as tyl), m, e) ->
-- let tyl' =
-- List.fold_left
-- (fun tyl ty ->
-- if List.exists (fun ty' -> equal env false [ty] [ty']) tyl
-- then tyl else ty::tyl)
-- [ty] tyl
-+ match f with Reither(b, tyl, m, tp, e) ->
-+ let rem_dbl eq l =
-+ List.rev
-+ (List.fold_left
-+ (fun xs x -> if List.exists (eq x) xs then xs else x::xs)
-+ [] l)
-+ in
-+ let tyl' = rem_dbl (fun t1 t2 -> equal env false [t1] [t2]) tyl
-+ and tp' =
-+ List.filter
-+ (fun (ty1,ty2) -> not (equal env false [ty1] [ty2])) tp
-+ in
-+ let tp' =
-+ rem_dbl
-+ (fun (t1,t2) (t1',t2') -> equal env false [t1;t2] [t1';t2'])
-+ tp'
- in
-- if List.length tyl' <= List.length tyl then
-- let f = Reither(b, List.rev tyl', m, ref None) in
-+ if List.length tyl' < List.length tyl
-+ || List.length tp' < List.length tp then
-+ let f = Reither(b, tyl', m, tp', ref None) in
- set_row_field e f;
- f
- else f
-@@ -3344,9 +3639,9 @@
- List.iter
- (fun (l,fi) ->
- match row_field_repr fi with
-- Reither (c, t1::(_::_ as tl), m, e) ->
-+ Reither (c, t1::(_::_ as tl), m, tp, e) ->
- List.iter (unify env t1) tl;
-- set_row_field e (Reither (c, [t1], m, ref None))
-+ set_row_field e (Reither (c, [t1], m, tp, ref None))
- | _ ->
- ())
- row.row_fields;
-Index: typing/includecore.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/includecore.ml,v
-retrieving revision 1.32
-diff -u -r1.32 includecore.ml
---- typing/includecore.ml 8 Aug 2005 05:40:52 -0000 1.32
-+++ typing/includecore.ml 2 Feb 2006 06:28:32 -0000
-@@ -71,10 +71,10 @@
- (fun (_, f1, f2) ->
- match Btype.row_field_repr f1, Btype.row_field_repr f2 with
- Rpresent(Some t1),
-- (Rpresent(Some t2) | Reither(false, [t2], _, _)) ->
-+ (Rpresent(Some t2) | Reither(false,[t2],_,[],_)) ->
- to_equal := (t1,t2) :: !to_equal; true
-- | Rpresent None, (Rpresent None | Reither(true, [], _, _)) -> true
-- | Reither(c1,tl1,_,_), Reither(c2,tl2,_,_)
-+ | Rpresent None, (Rpresent None | Reither(true,[],_,[],_)) -> true
-+ | Reither(c1,tl1,_,[],_), Reither(c2,tl2,_,[],_)
- when List.length tl1 = List.length tl2 && c1 = c2 ->
- to_equal := List.combine tl1 tl2 @ !to_equal; true
- | Rabsent, (Reither _ | Rabsent) -> true
-Index: typing/oprint.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/oprint.ml,v
-retrieving revision 1.22
-diff -u -r1.22 oprint.ml
---- typing/oprint.ml 23 Mar 2005 03:08:37 -0000 1.22
-+++ typing/oprint.ml 2 Feb 2006 06:28:33 -0000
-@@ -223,14 +223,18 @@
- print_fields rest ppf []
- | (s, t) :: l ->
- fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l
--and print_row_field ppf (l, opt_amp, tyl) =
-+and print_row_field ppf (l, opt_amp, tyl, tpl) =
- let pr_of ppf =
- if opt_amp then fprintf ppf " of@ &@ "
- else if tyl <> [] then fprintf ppf " of@ "
-- else fprintf ppf ""
-- in
-- fprintf ppf "@[<hv 2>`%s%t%a@]" l pr_of (print_typlist print_out_type " &")
-- tyl
-+ and pr_tp ppf (t1,t2) =
-+ fprintf ppf "@[<hv 2>%a =@ %a@]"
-+ print_out_type t1
-+ print_out_type t2
-+ in
-+ fprintf ppf "@[<hv 2>`%s%t%a%a@]" l pr_of
-+ (print_typlist print_out_type " &") tyl
-+ (print_list_init pr_tp (fun ppf -> fprintf ppf " &@ ")) tpl
- and print_typlist print_elem sep ppf =
- function
- [] -> ()
-Index: typing/outcometree.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/outcometree.mli,v
-retrieving revision 1.14
-diff -u -r1.14 outcometree.mli
---- typing/outcometree.mli 23 Mar 2005 03:08:37 -0000 1.14
-+++ typing/outcometree.mli 2 Feb 2006 06:28:33 -0000
-@@ -61,7 +61,8 @@
- bool * out_variant * bool * (string list) option
- | Otyp_poly of string list * out_type
- and out_variant =
-- | Ovar_fields of (string * bool * out_type list) list
-+ | Ovar_fields of
-+ (string * bool * out_type list * (out_type * out_type) list ) list
- | Ovar_name of out_ident * out_type list
-
- type out_class_type =
-Index: typing/parmatch.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/parmatch.ml,v
-retrieving revision 1.70
-diff -u -r1.70 parmatch.ml
---- typing/parmatch.ml 24 Mar 2005 17:20:54 -0000 1.70
-+++ typing/parmatch.ml 2 Feb 2006 06:28:33 -0000
-@@ -568,11 +568,11 @@
- List.fold_left
- (fun nm (tag,f) ->
- match Btype.row_field_repr f with
-- | Reither(_, _, false, e) ->
-+ | Reither(_, _, false, _, e) ->
- (* m=false means that this tag is not explicitly matched *)
- Btype.set_row_field e Rabsent;
- None
-- | Rabsent | Reither (_, _, true, _) | Rpresent _ -> nm)
-+ | Rabsent | Reither (_, _, true, _, _) | Rpresent _ -> nm)
- row.row_name row.row_fields in
- if not row.row_closed || nm != row.row_name then begin
- (* this unification cannot fail *)
-@@ -605,8 +605,8 @@
- List.for_all
- (fun (tag,f) ->
- match Btype.row_field_repr f with
-- Rabsent | Reither(_, _, false, _) -> true
-- | Reither (_, _, true, _)
-+ Rabsent | Reither(_, _, false, _, _) -> true
-+ | Reither (_, _, true, _, _)
- (* m=true, do not discard matched tags, rather warn *)
- | Rpresent _ -> List.mem tag fields)
- row.row_fields
-@@ -739,7 +739,7 @@
- match Btype.row_field_repr f with
- Rabsent (* | Reither _ *) -> others
- (* This one is called after erasing pattern info *)
-- | Reither (c, _, _, _) -> make_other_pat tag c :: others
-+ | Reither (c, _, _, _, _) -> make_other_pat tag c :: others
- | Rpresent arg -> make_other_pat tag (arg = None) :: others)
- [] row.row_fields
- with
-Index: typing/printtyp.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/printtyp.ml,v
-retrieving revision 1.140
-diff -u -r1.140 printtyp.ml
---- typing/printtyp.ml 4 Jan 2006 16:55:50 -0000 1.140
-+++ typing/printtyp.ml 2 Feb 2006 06:28:33 -0000
-@@ -157,9 +157,12 @@
- and raw_field ppf = function
- Rpresent None -> fprintf ppf "Rpresent None"
- | Rpresent (Some t) -> fprintf ppf "@[<1>Rpresent(Some@,%a)@]" raw_type t
-- | Reither (c,tl,m,e) ->
-- fprintf ppf "@[<hov1>Reither(%b,@,%a,@,%b,@,@[<1>ref%t@])@]" c
-- raw_type_list tl m
-+ | Reither (c,tl,m,tpl,e) ->
-+ fprintf ppf "@[<hov1>Reither(%b,@,%a,@,%b,@,%a,@,@[<1>ref%t@])@]"
-+ c raw_type_list tl m
-+ (raw_list
-+ (fun ppf (t1,t2) ->
-+ fprintf ppf "@[%a,@,%a@]" raw_type t1 raw_type t2)) tpl
- (fun ppf ->
- match !e with None -> fprintf ppf " None"
- | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f)
-@@ -219,8 +222,9 @@
- List.for_all
- (fun (_, f) ->
- match row_field_repr f with
-- | Reither(c, l, _, _) ->
-- row.row_closed && if c then l = [] else List.length l = 1
-+ | Reither(c, l, _, pl, _) ->
-+ row.row_closed && pl = [] &&
-+ if c then l = [] else List.length l = 1
- | _ -> true)
- row.row_fields
-
-@@ -392,13 +396,16 @@
-
- and tree_of_row_field sch (l, f) =
- match row_field_repr f with
-- | Rpresent None | Reither(true, [], _, _) -> (l, false, [])
-- | Rpresent(Some ty) -> (l, false, [tree_of_typexp sch ty])
-- | Reither(c, tyl, _, _) ->
-- if c (* contradiction: un constructeur constant qui a un argument *)
-- then (l, true, tree_of_typlist sch tyl)
-- else (l, false, tree_of_typlist sch tyl)
-- | Rabsent -> (l, false, [] (* une erreur, en fait *))
-+ | Rpresent None | Reither(true, [], _, [], _) -> (l, false, [], [])
-+ | Rpresent(Some ty) -> (l, false, [tree_of_typexp sch ty], [])
-+ | Reither(c, tyl, _, tpl, _) ->
-+ let ttpl =
-+ List.map
-+ (fun (t1,t2) -> tree_of_typexp sch t1, tree_of_typexp sch t2)
-+ tpl
-+ in
-+ (l, c && tpl = [], tree_of_typlist sch tyl, ttpl)
-+ | Rabsent -> (l, false, [], [] (* une erreur, en fait *))
-
- and tree_of_typlist sch tyl =
- List.map (tree_of_typexp sch) tyl
-Index: typing/typeclass.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typeclass.ml,v
-retrieving revision 1.85
-diff -u -r1.85 typeclass.ml
---- typing/typeclass.ml 22 Jul 2005 06:42:36 -0000 1.85
-+++ typing/typeclass.ml 2 Feb 2006 06:28:33 -0000
-@@ -727,7 +727,7 @@
- {pexp_loc = loc; pexp_desc =
- Pexp_match({pexp_loc = loc; pexp_desc =
- Pexp_ident(Longident.Lident"*opt*")},
-- scases)} in
-+ scases, false)} in
- let sfun =
- {pcl_loc = scl.pcl_loc; pcl_desc =
- Pcl_fun(l, None, {ppat_loc = loc; ppat_desc = Ppat_var"*opt*"},
-Index: typing/typecore.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v
-retrieving revision 1.178
-diff -u -r1.178 typecore.ml
---- typing/typecore.ml 6 Jan 2006 02:25:37 -0000 1.178
-+++ typing/typecore.ml 2 Feb 2006 06:28:33 -0000
-@@ -156,15 +156,21 @@
- let field = row_field tag row in
- begin match field with
- | Rabsent -> assert false
-- | Reither (true, [], _, e) when not row.row_closed ->
-- set_row_field e (Rpresent None)
-- | Reither (false, ty::tl, _, e) when not row.row_closed ->
-+ | Reither (true, [], _, tpl, e) when not row.row_closed ->
-+ set_row_field e (Rpresent None);
-+ List.iter
-+ (fun (t1,t2) -> unify_pat pat.pat_env {pat with pat_type=t1} t2)
-+ tpl
-+ | Reither (false, ty::tl, _, tpl, e) when not row.row_closed ->
- set_row_field e (Rpresent (Some ty));
-+ List.iter
-+ (fun (t1,t2) -> unify_pat pat.pat_env {pat with pat_type=t1} t2)
-+ tpl;
- begin match opat with None -> assert false
- | Some pat -> List.iter (unify_pat pat.pat_env pat) (ty::tl)
- end
-- | Reither (c, l, true, e) when not row.row_fixed ->
-- set_row_field e (Reither (c, [], false, ref None))
-+ | Reither (c, l, true, tpl, e) when not row.row_fixed ->
-+ set_row_field e (Reither (c, [], false, [], ref None))
- | _ -> ()
- end;
- (* Force check of well-formedness *)
-@@ -307,13 +313,13 @@
- match row_field_repr f with
- Rpresent None ->
- (l,None) :: pats,
-- (l, Reither(true,[], true, ref None)) :: fields
-+ (l, Reither(true,[], true, [], ref None)) :: fields
- | Rpresent (Some ty) ->
- bound := ty :: !bound;
- (l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env;
- pat_type=ty})
- :: pats,
-- (l, Reither(false, [ty], true, ref None)) :: fields
-+ (l, Reither(false, [ty], true, [], ref None)) :: fields
- | _ -> pats, fields)
- ([],[]) fields in
- let row =
-@@ -337,6 +343,18 @@
- pat pats in
- rp { r with pat_loc = loc }
-
-+let rec flatten_or_pat pat =
-+ match pat.pat_desc with
-+ Tpat_or (p1, p2, _) ->
-+ flatten_or_pat p1 @ flatten_or_pat p2
-+ | _ ->
-+ [pat]
-+
-+let all_variants pat =
-+ List.for_all
-+ (function {pat_desc=Tpat_variant _} -> true | _ -> false)
-+ (flatten_or_pat pat)
-+
- let rec find_record_qual = function
- | [] -> None
- | (Longident.Ldot (modname, _), _) :: _ -> Some modname
-@@ -423,7 +441,7 @@
- let arg = may_map (type_pat env) sarg in
- let arg_type = match arg with None -> [] | Some arg -> [arg.pat_type] in
- let row = { row_fields =
-- [l, Reither(arg = None, arg_type, true, ref None)];
-+ [l, Reither(arg = None, arg_type, true, [], ref None)];
- row_bound = arg_type;
- row_closed = false;
- row_more = newvar ();
-@@ -788,7 +806,7 @@
- newty (Tarrow(p, type_option (newvar ()), type_approx env e, Cok))
- | Pexp_function (p,_,(_,e)::_) ->
- newty (Tarrow(p, newvar (), type_approx env e, Cok))
-- | Pexp_match (_, (_,e)::_) -> type_approx env e
-+ | Pexp_match (_, (_,e)::_, false) -> type_approx env e
- | Pexp_try (e, _) -> type_approx env e
- | Pexp_tuple l -> newty (Ttuple(List.map (type_approx env) l))
- | Pexp_ifthenelse (_,e,_) -> type_approx env e
-@@ -939,17 +957,26 @@
- exp_loc = sexp.pexp_loc;
- exp_type = ty_res;
- exp_env = env }
-- | Pexp_match(sarg, caselist) ->
-+ | Pexp_match(sarg, caselist, multi) ->
- let arg = type_exp env sarg in
- let ty_res = newvar() in
- let cases, partial =
-- type_cases env arg.exp_type ty_res (Some sexp.pexp_loc) caselist
-+ type_cases env arg.exp_type ty_res (Some sexp.pexp_loc) caselist ~multi
- in
- re {
- exp_desc = Texp_match(arg, cases, partial);
- exp_loc = sexp.pexp_loc;
- exp_type = ty_res;
- exp_env = env }
-+ | Pexp_multifun caselist ->
-+ let ty_arg = newvar() and ty_res = newvar() in
-+ let cases, partial =
-+ type_cases env ty_arg ty_res (Some sexp.pexp_loc) caselist ~multi:true
-+ in
-+ { exp_desc = Texp_function (cases, partial);
-+ exp_loc = sexp.pexp_loc;
-+ exp_type = newty (Tarrow ("", ty_arg, ty_res, Cok));
-+ exp_env = env }
- | Pexp_try(sbody, caselist) ->
- let body = type_exp env sbody in
- let cases, _ =
-@@ -1758,7 +1785,7 @@
- {pexp_loc = loc; pexp_desc =
- Pexp_match({pexp_loc = loc; pexp_desc =
- Pexp_ident(Longident.Lident"*opt*")},
-- scases)} in
-+ scases, false)} in
- let sfun =
- {pexp_loc = sexp.pexp_loc; pexp_desc =
- Pexp_function(l, None,[{ppat_loc = loc; ppat_desc = Ppat_var"*opt*"},
-@@ -1864,7 +1891,8 @@
-
- (* Typing of match cases *)
-
--and type_cases ?in_function env ty_arg ty_res partial_loc caselist =
-+and type_cases ?in_function ?(multi=false)
-+ env ty_arg ty_res partial_loc caselist =
- let ty_arg' = newvar () in
- let pattern_force = ref [] in
- let pat_env_list =
-@@ -1898,10 +1926,64 @@
- let cases =
- List.map2
- (fun (pat, ext_env) (spat, sexp) ->
-- let exp = type_expect ?in_function ext_env sexp ty_res in
-- (pat, exp))
-- pat_env_list caselist
-- in
-+ let add_variant_case lab row ty_res ty_res' =
-+ let fi = List.assoc lab (row_repr row).row_fields in
-+ begin match row_field_repr fi with
-+ Reither (c, _, m, _, e) ->
-+ let row' =
-+ { row_fields =
-+ [lab, Reither(c,[],false,[ty_res,ty_res'], ref None)];
-+ row_more = newvar (); row_bound = [ty_res; ty_res'];
-+ row_closed = false; row_fixed = false; row_name = None }
-+ in
-+ unify_pat ext_env {pat with pat_type= newty (Tvariant row)}
-+ (newty (Tvariant row'))
-+ | _ ->
-+ unify_exp ext_env
-+ { exp_desc = Texp_tuple []; exp_type = ty_res;
-+ exp_env = ext_env; exp_loc = sexp.pexp_loc }
-+ ty_res'
-+ end
-+ in
-+ pat,
-+ match pat.pat_desc with
-+ _ when multi && all_variants pat ->
-+ let ty_res' = newvar () in
-+ List.iter
-+ (function {pat_desc=Tpat_variant(lab,_,row)} ->
-+ add_variant_case lab row ty_res ty_res'
-+ | _ -> assert false)
-+ (flatten_or_pat pat);
-+ type_expect ?in_function ext_env sexp ty_res'
-+ | Tpat_alias (p, id) when multi && all_variants p ->
-+ let vd = Env.find_value (Path.Pident id) ext_env in
-+ let row' =
-+ match repr vd.val_type with
-+ {desc=Tvariant row'} -> row'
-+ | _ -> assert false
-+ in
-+ begin_def ();
-+ let tv = newvar () in
-+ let env = Env.add_value id {vd with val_type=tv} ext_env in
-+ let exp = type_exp env sexp in
-+ end_def ();
-+ generalize exp.exp_type;
-+ generalize tv;
-+ List.iter
-+ (function {pat_desc=Tpat_variant(lab,_,row)}, [tv'; ty'] ->
-+ let fi' = List.assoc lab (row_repr row').row_fields in
-+ let row' =
-+ {row' with row_fields=[lab,fi']; row_more=newvar()} in
-+ unify_pat ext_env {pat with pat_type=tv'}
-+ (newty (Tvariant row'));
-+ add_variant_case lab row ty_res ty'
-+ | _ -> assert false)
-+ (List.map (fun p -> p, instance_list [tv; exp.exp_type])
-+ (flatten_or_pat p));
-+ {exp with exp_type = instance exp.exp_type}
-+ | _ ->
-+ type_expect ?in_function ext_env sexp ty_res)
-+ pat_env_list caselist in
- let partial =
- match partial_loc with None -> Partial
- | Some loc -> Parmatch.check_partial loc cases
-Index: typing/typedecl.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typedecl.ml,v
-retrieving revision 1.75
-diff -u -r1.75 typedecl.ml
---- typing/typedecl.ml 16 Aug 2005 00:48:56 -0000 1.75
-+++ typing/typedecl.ml 2 Feb 2006 06:28:33 -0000
-@@ -432,8 +432,10 @@
- match Btype.row_field_repr f with
- Rpresent (Some ty) ->
- compute_same ty
-- | Reither (_, tyl, _, _) ->
-- List.iter compute_same tyl
-+ | Reither (_, tyl, _, tpl, _) ->
-+ List.iter compute_same tyl;
-+ List.iter (compute_variance_rec true true true)
-+ (List.map fst tpl @ List.map snd tpl)
- | _ -> ())
- row.row_fields;
- compute_same row.row_more
-@@ -856,8 +858,8 @@
- explain row.row_fields
- (fun (l,f) -> match Btype.row_field_repr f with
- Rpresent (Some t) -> t
-- | Reither (_,[t],_,_) -> t
-- | Reither (_,tl,_,_) -> Btype.newgenty (Ttuple tl)
-+ | Reither (_,[t],_,_,_) -> t
-+ | Reither (_,tl,_,_,_) -> Btype.newgenty (Ttuple tl)
- | _ -> Btype.newgenty (Ttuple[]))
- "case" (fun (lab,_) -> "`" ^ lab ^ " of ")
- | _ -> trivial ty'
-Index: typing/types.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/types.ml,v
-retrieving revision 1.25
-diff -u -r1.25 types.ml
---- typing/types.ml 9 Dec 2004 12:40:53 -0000 1.25
-+++ typing/types.ml 2 Feb 2006 06:28:33 -0000
-@@ -48,7 +48,9 @@
-
- and row_field =
- Rpresent of type_expr option
-- | Reither of bool * type_expr list * bool * row_field option ref
-+ | Reither of
-+ bool * type_expr list * bool *
-+ (type_expr * type_expr) list * row_field option ref
- | Rabsent
-
- and abbrev_memo =
-Index: typing/types.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/types.mli,v
-retrieving revision 1.25
-diff -u -r1.25 types.mli
---- typing/types.mli 9 Dec 2004 12:40:53 -0000 1.25
-+++ typing/types.mli 2 Feb 2006 06:28:33 -0000
-@@ -47,7 +47,9 @@
-
- and row_field =
- Rpresent of type_expr option
-- | Reither of bool * type_expr list * bool * row_field option ref
-+ | Reither of
-+ bool * type_expr list * bool *
-+ (type_expr * type_expr) list * row_field option ref
- (* 1st true denotes a constant constructor *)
- (* 2nd true denotes a tag in a pattern matching, and
- is erased later *)
-Index: typing/typetexp.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typetexp.ml,v
-retrieving revision 1.54
-diff -u -r1.54 typetexp.ml
---- typing/typetexp.ml 22 Jul 2005 06:42:36 -0000 1.54
-+++ typing/typetexp.ml 2 Feb 2006 06:28:33 -0000
-@@ -207,9 +207,9 @@
- match Btype.row_field_repr f with
- | Rpresent (Some ty) ->
- bound := ty :: !bound;
-- Reither(false, [ty], false, ref None)
-+ Reither(false, [ty], false, [], ref None)
- | Rpresent None ->
-- Reither (true, [], false, ref None)
-+ Reither (true, [], false, [], ref None)
- | _ -> f)
- row.row_fields
- in
-@@ -273,13 +273,16 @@
- (l, f) :: fields
- in
- let rec add_field fields = function
-- Rtag (l, c, stl) ->
-+ Rtag (l, c, stl, stpl) ->
- name := None;
- let f = match present with
- Some present when not (List.mem l present) ->
-- let tl = List.map (transl_type env policy) stl in
-- bound := tl @ !bound;
-- Reither(c, tl, false, ref None)
-+ let transl_list = List.map (transl_type env policy) in
-+ let tl = transl_list stl in
-+ let stpl1, stpl2 = List.split stpl in
-+ let tpl1 = transl_list stpl1 and tpl2 = transl_list stpl2 in
-+ bound := tl @ tpl1 @ tpl2 @ !bound;
-+ Reither(c, tl, false, List.combine tpl1 tpl2, ref None)
- | _ ->
- if List.length stl > 1 || c && stl <> [] then
- raise(Error(styp.ptyp_loc, Present_has_conjunction l));
-@@ -311,9 +314,9 @@
- begin match f with
- Rpresent(Some ty) ->
- bound := ty :: !bound;
-- Reither(false, [ty], false, ref None)
-+ Reither(false, [ty], false, [], ref None)
- | Rpresent None ->
-- Reither(true, [], false, ref None)
-+ Reither(true, [], false, [], ref None)
- | _ ->
- assert false
- end
-@@ -406,7 +409,8 @@
- {row with row_fixed=true;
- row_fields = List.map
- (fun (s,f as p) -> match Btype.row_field_repr f with
-- Reither (c, tl, m, r) -> s, Reither (c, tl, true, r)
-+ Reither (c, tl, m, tpl, r) ->
-+ s, Reither (c, tl, true, tpl, r)
- | _ -> p)
- row.row_fields};
- Btype.iter_row make_fixed_univars row
-Index: typing/unused_var.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/unused_var.ml,v
-retrieving revision 1.5
-diff -u -r1.5 unused_var.ml
---- typing/unused_var.ml 4 Jan 2006 16:55:50 -0000 1.5
-+++ typing/unused_var.ml 2 Feb 2006 06:28:33 -0000
-@@ -122,9 +122,11 @@
- | Pexp_apply (e, lel) ->
- expression ppf tbl e;
- List.iter (fun (_, e) -> expression ppf tbl e) lel;
-- | Pexp_match (e, pel) ->
-+ | Pexp_match (e, pel, _) ->
- expression ppf tbl e;
- match_pel ppf tbl pel;
-+ | Pexp_multifun pel ->
-+ match_pel ppf tbl pel;
- | Pexp_try (e, pel) ->
- expression ppf tbl e;
- match_pel ppf tbl pel;
-Index: bytecomp/matching.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/matching.ml,v
-retrieving revision 1.67
-diff -u -r1.67 matching.ml
---- bytecomp/matching.ml 7 Sep 2005 16:07:48 -0000 1.67
-+++ bytecomp/matching.ml 2 Feb 2006 06:28:33 -0000
-@@ -1991,7 +1991,7 @@
- List.iter
- (fun (_, f) ->
- match Btype.row_field_repr f with
-- Rabsent | Reither(true, _::_, _, _) -> ()
-+ Rabsent | Reither(true, _::_, _, _, _) -> ()
- | _ -> incr num_constr)
- row.row_fields
- else
-Index: toplevel/genprintval.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/toplevel/genprintval.ml,v
-retrieving revision 1.38
-diff -u -r1.38 genprintval.ml
---- toplevel/genprintval.ml 13 Jun 2005 04:55:53 -0000 1.38
-+++ toplevel/genprintval.ml 2 Feb 2006 06:28:33 -0000
-@@ -293,7 +293,7 @@
- | (l, f) :: fields ->
- if Btype.hash_variant l = tag then
- match Btype.row_field_repr f with
-- | Rpresent(Some ty) | Reither(_,[ty],_,_) ->
-+ | Rpresent(Some ty) | Reither(_,[ty],_,_,_) ->
- let args =
- tree_of_val (depth - 1) (O.field obj 1) ty in
- Oval_variant (l, Some args)
+++ /dev/null
-(* Simple example *)
-let f x =
- (multimatch x with `A -> 1 | `B -> true),
- (multimatch x with `A -> 1. | `B -> "1");;
-
-(* OK *)
-module M : sig
- val f :
- [< `A & 'a = int & 'b = float | `B & 'b =string & 'a = bool] -> 'a * 'b
-end = struct let f = f end;;
-
-(* Bad *)
-module M : sig
- val f :
- [< `A & 'a = int & 'b = float | `B & 'b =string & 'a = int] -> 'a * 'b
-end = struct let f = f end;;
-
-(* Should be good! *)
-module M : sig
- val f :
- [< `A & 'a = int * float | `B & 'a = bool * string] -> 'a
-end = struct let f = f end;;
-
-let f = multifun `A|`B as x -> f x;;
-
-(* Two-level example *)
-let f = multifun
- `A -> (multifun `C -> 1 | `D -> 1.)
- | `B -> (multifun `C -> true | `D -> "1");;
-
-(* OK *)
-module M : sig
- val f :
- [< `A & 'b = [< `C & 'a = int | `D & 'a = float & 'c = bool] -> 'a
- | `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b
-end = struct let f = f end;;
-
-(* Bad *)
-module M : sig
- val f :
- [< `A & 'b = [< `C & 'a = int | `D & 'a = bool] -> 'a
- | `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b
-end = struct let f = f end;;
-
-module M : sig
- val f :
- [< `A & 'b = [< `C & 'a = int | `D] -> 'a
- | `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b
-end = struct let f = f end;;
-
-
-(* Examples with hidden sharing *)
-let r = ref []
-let f = multifun `A -> 1 | `B -> true
-let g x = r := [f x];;
-
-(* Bad! *)
-module M : sig
- val g : [< `A & 'a = int | `B & 'a = bool] -> unit
-end = struct let g = g end;;
-
-let r = ref []
-let f = multifun `A -> r | `B -> ref [];;
-(* Now OK *)
-module M : sig
- val f : [< `A & 'b = int list ref | `B & 'b = 'c list ref] -> 'b
-end = struct let f = f end;;
-(* Still OK *)
-let l : int list ref = r;;
-module M : sig
- val f : [< `A & 'b = int list ref | `B & 'b = 'c list ref] -> 'b
-end = struct let f = f end;;
-
-
-(* Examples that would need unification *)
-let f = multifun `A -> (1, []) | `B -> (true, [])
-let g x = fst (f x);;
-(* Didn't work, now Ok *)
-module M : sig
- val g : [< `A & 'a * 'b = int * bool | `B & 'a * 'b = bool * int] -> 'a
-end = struct let g = g end;;
-let g = multifun (`A|`B) as x -> g x;;
-
-(* Other examples *)
-
-let f x =
- let a = multimatch x with `A -> 1 | `B -> "1" in
- (multifun `A -> print_int | `B -> print_string) x a
-;;
-
-let f = multifun (`A|`B) as x -> f x;;
-
-type unit_op = [`Set of int | `Move of int]
-type int_op = [`Get]
-
-let op r =
- multifun
- `Get -> !r
- | `Set x -> r := x
- | `Move dx -> r := !r + dx
-;;
-
-let rec trace r = function
- [] -> []
- | op1 :: ops ->
- multimatch op1 with
- #int_op as op1 ->
- let x = op r op1 in
- x :: trace r ops
- | #unit_op as op1 ->
- op r op1;
- trace r ops
-;;
-
-class point x = object
- val mutable x : int = x
- method get = x
- method set y = x <- y
- method move dx = x <- x + dx
-end;;
-
-let poly sort coeffs x =
- let add, mul, zero =
- multimatch sort with
- `Int -> (+), ( * ), 0
- | `Float -> (+.), ( *. ), 0.
- in
- let rec compute = function
- [] -> zero
- | c :: cs -> add c (mul x (compute cs))
- in
- compute coeffs
-;;
-
-module M : sig
- val poly : [< `Int & 'a = int | `Float & 'a = float] -> 'a list -> 'a -> 'a
-end = struct let poly = poly end;;
-
-type ('a,'b) num_sort =
- 'b constraint 'b = [< `Int & 'a = int | `Float & 'a = float]
-module M : sig
- val poly : ('a,_) num_sort -> 'a list -> 'a -> 'a
-end = struct let poly = poly end;;
-
-
-(* type dispatch *)
-
-type num = [ `Int | `Float ]
-let print0 = multifun
- `Int -> print_int
- | `Float -> print_float
-;;
-let print1 = multifun
- #num as x -> print0 x
- | `List t -> List.iter (print0 t)
- | `Pair(t1,t2) -> (fun (x,y) -> print0 t1 x; print0 t2 y)
-;;
-print1 (`Pair(`Int,`Float)) (1,1.0);;
+++ /dev/null
-%!PS-Adobe-2.0
-%%Creator: dvipsk 5.78 p1.4 Copyright 1996-98 ASCII Corp.(www-ptex@ascii.co.jp)
-%%dvipsk 5.78 Copyright 1998 Radical Eye Software (www.radicaleye.com)
-%%Title: newlabels.dvi
-%%Pages: 2 0
-%%PageOrder: Ascend
-%%BoundingBox: 0 0 596 842
-%%EndComments
-%%BeginProcSet: PStoPS 1 15
-userdict begin
-[/showpage/erasepage/copypage]{dup where{pop dup load
- type/operatortype eq{1 array cvx dup 0 3 index cvx put
- bind def}{pop}ifelse}{pop}ifelse}forall
-[/letter/legal/executivepage/a4/a4small/b5/com10envelope
- /monarchenvelope/c5envelope/dlenvelope/lettersmall/note
- /folio/quarto/a5]{dup where{dup wcheck{exch{}put}
- {pop{}def}ifelse}{pop}ifelse}forall
-/setpagedevice {pop}bind 1 index where{dup wcheck{3 1 roll put}
- {pop def}ifelse}{def}ifelse
-/PStoPSmatrix matrix currentmatrix def
-/PStoPSxform matrix def/PStoPSclip{clippath}def
-/defaultmatrix{PStoPSmatrix exch PStoPSxform exch concatmatrix}bind def
-/initmatrix{matrix defaultmatrix setmatrix}bind def
-/initclip[{matrix currentmatrix PStoPSmatrix setmatrix
- [{currentpoint}stopped{$error/newerror false put{newpath}}
- {/newpath cvx 3 1 roll/moveto cvx 4 array astore cvx}ifelse]
- {[/newpath cvx{/moveto cvx}{/lineto cvx}
- {/curveto cvx}{/closepath cvx}pathforall]cvx exch pop}
- stopped{$error/errorname get/invalidaccess eq{cleartomark
- $error/newerror false put cvx exec}{stop}ifelse}if}bind aload pop
- /initclip dup load dup type dup/operatortype eq{pop exch pop}
- {dup/arraytype eq exch/packedarraytype eq or
- {dup xcheck{exch pop aload pop}{pop cvx}ifelse}
- {pop cvx}ifelse}ifelse
- {newpath PStoPSclip clip newpath exec setmatrix} bind aload pop]cvx def
-/initgraphics{initmatrix newpath initclip 1 setlinewidth
- 0 setlinecap 0 setlinejoin []0 setdash 0 setgray
- 10 setmiterlimit}bind def
-end
-%%EndProcSet
-%DVIPSCommandLine: dvips -f newlabels
-%DVIPSParameters: dpi=300
-%DVIPSSource: TeX output 1999.10.26:1616
-%%BeginProcSet: tex.pro
-%!
-/TeXDict 300 dict def TeXDict begin /N{def}def /B{bind def}N /S{exch}N
-/X{S N}B /TR{translate}N /isls false N /vsize 11 72 mul N /hsize 8.5 72
-mul N /landplus90{false}def /@rigin{isls{[0 landplus90{1 -1}{-1 1}
-ifelse 0 0 0]concat}if 72 Resolution div 72 VResolution div neg scale
-isls{landplus90{VResolution 72 div vsize mul 0 exch}{Resolution -72 div
-hsize mul 0}ifelse TR}if Resolution VResolution vsize -72 div 1 add mul
-TR[matrix currentmatrix{dup dup round sub abs 0.00001 lt{round}if}
-forall round exch round exch]setmatrix}N /@landscape{/isls true N}B
-/@manualfeed{statusdict /manualfeed true put}B /@copies{/#copies X}B
-/FMat[1 0 0 -1 0 0]N /FBB[0 0 0 0]N /nn 0 N /IE 0 N /ctr 0 N /df-tail{
-/nn 8 dict N nn begin /FontType 3 N /FontMatrix fntrx N /FontBBox FBB N
-string /base X array /BitMaps X /BuildChar{CharBuilder}N /Encoding IE N
-end dup{/foo setfont}2 array copy cvx N load 0 nn put /ctr 0 N[}B /df{
-/sf 1 N /fntrx FMat N df-tail}B /dfs{div /sf X /fntrx[sf 0 0 sf neg 0 0]
-N df-tail}B /E{pop nn dup definefont setfont}B /ch-width{ch-data dup
-length 5 sub get}B /ch-height{ch-data dup length 4 sub get}B /ch-xoff{
-128 ch-data dup length 3 sub get sub}B /ch-yoff{ch-data dup length 2 sub
-get 127 sub}B /ch-dx{ch-data dup length 1 sub get}B /ch-image{ch-data
-dup type /stringtype ne{ctr get /ctr ctr 1 add N}if}B /id 0 N /rw 0 N
-/rc 0 N /gp 0 N /cp 0 N /G 0 N /sf 0 N /CharBuilder{save 3 1 roll S dup
-/base get 2 index get S /BitMaps get S get /ch-data X pop /ctr 0 N ch-dx
-0 ch-xoff ch-yoff ch-height sub ch-xoff ch-width add ch-yoff
-setcachedevice ch-width ch-height true[1 0 0 -1 -.1 ch-xoff sub ch-yoff
-.1 sub]{ch-image}imagemask restore}B /D{/cc X dup type /stringtype ne{]}
-if nn /base get cc ctr put nn /BitMaps get S ctr S sf 1 ne{dup dup
-length 1 sub dup 2 index S get sf div put}if put /ctr ctr 1 add N}B /I{
-cc 1 add D}B /bop{userdict /bop-hook known{bop-hook}if /SI save N @rigin
-0 0 moveto /V matrix currentmatrix dup 1 get dup mul exch 0 get dup mul
-add .99 lt{/QV}{/RV}ifelse load def pop pop}N /eop{SI restore userdict
-/eop-hook known{eop-hook}if showpage}N /@start{userdict /start-hook
-known{start-hook}if pop /VResolution X /Resolution X 1000 div /DVImag X
-/IE 256 array N 2 string 0 1 255{IE S dup 360 add 36 4 index cvrs cvn
-put}for pop 65781.76 div /vsize X 65781.76 div /hsize X}N /p{show}N
-/RMat[1 0 0 -1 0 0]N /BDot 260 string N /rulex 0 N /ruley 0 N /v{/ruley
-X /rulex X V}B /V{}B /RV statusdict begin /product where{pop false[
-(Display)(NeXT)(LaserWriter 16/600)]{dup length product length le{dup
-length product exch 0 exch getinterval eq{pop true exit}if}{pop}ifelse}
-forall}{false}ifelse end{{gsave TR -.1 .1 TR 1 1 scale rulex ruley false
-RMat{BDot}imagemask grestore}}{{gsave TR -.1 .1 TR rulex ruley scale 1 1
-false RMat{BDot}imagemask grestore}}ifelse B /QV{gsave newpath transform
-round exch round exch itransform moveto rulex 0 rlineto 0 ruley neg
-rlineto rulex neg 0 rlineto fill grestore}B /a{moveto}B /delta 0 N /tail
-{dup /delta X 0 rmoveto}B /M{S p delta add tail}B /b{S p tail}B /c{-4 M}
-B /d{-3 M}B /e{-2 M}B /f{-1 M}B /g{0 M}B /h{1 M}B /i{2 M}B /j{3 M}B /k{
-4 M}B /w{0 rmoveto}B /l{p -4 w}B /m{p -3 w}B /n{p -2 w}B /o{p -1 w}B /q{
-p 1 w}B /r{p 2 w}B /s{p 3 w}B /t{p 4 w}B /x{0 S rmoveto}B /y{3 2 roll p
-a}B /bos{/SS save N}B /eos{SS restore}B end
-
-%%EndProcSet
-TeXDict begin 39158280 55380996 1000 300 300 (newlabels.dvi)
-@start
-%DVIPSBitmapFont: Fa cmr6 6 2
-/Fa 2 51 df<187898181818181818181818181818FF08107D8F0F> 49
-D<1F00618040C08060C0600060006000C00180030006000C00102020207FC0FFC00B107F
-8F0F> I E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fb cmmi8 8 4
-/Fb 4 111 df<FFC0FF1C00181C00101C00101C00103800203800203800203800207000
-40700040700040700040E00080E00080E00080E00080E00100E00200E004006008003830
-000FC00018177E9618> 85 D<0300038003000000000000000000000000001C00240046
-0046008C000C0018001800180031003100320032001C0009177F960C> 105
-D<383C1E0044C6630047028100460301008E0703000C0603000C0603000C060300180C06
-00180C0620180C0C20180C0C40301804C0301807001B0E7F8D1F> 109
-D<383C0044C6004702004602008E06000C06000C06000C0600180C00180C401818401818
-80300980300E00120E7F8D15> I E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fc cmbx8 8 4
-/Fc 4 111 df<01800780FF80FF80078007800780078007800780078007800780078007
-800780078007800780FFF8FFF80D157D9414> 49 D<387C7C7C3800000000FCFC3C3C3C
-3C3C3C3C3C3C3C3CFFFF08187F970B> 105 D<FC7E0FC0FD8730E03E07C0F03E07C0F03C
-0780F03C0780F03C0780F03C0780F03C0780F03C0780F03C0780F03C0780F03C0780F0FF
-1FE3FCFF1FE3FC1E0F7E8E23> 109 D<FC7C00FD8E003E0F003E0F003C0F003C0F003C0F
-003C0F003C0F003C0F003C0F003C0F003C0F00FF3FC0FF3FC0120F7E8E17> I
-E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fd cmsy8 8 3
-/Fd 3 93 df<FFFFF0FFFFF014027D881B> 0 D<020002000200C218F2783AE00F800F80
-3AE0F278C2180200020002000D0E7E8E12> 3 D<03F8001FFF003C07806000C0C00060C0
-0060C00060C00060C00060C00060C00060C00060C00060C00060C00060C00060C00060C0
-006040002013137E9218> 92 D E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fe cmtt12 12 43
-/Fe 43 125 df<01818003C3C003C3C003C3C003C3C003C3C003C3C07FFFF0FFFFF8FFFF
-F87FFFF00787800787800787800F8F800F0F000F0F000F0F000F0F007FFFF0FFFFF8FFFF
-F87FFFF01E1E001E1E001E1E001E1E001E1E001E1E000C0C00151E7E9D1A> 35
-D<00E00003F00007F8000738000E1C000E1C000E1C000E1C000E38000E39FC0E71FC07F1
-FC07E1C007C1C00781C00783800F83801FC3803DC70078E70070EE00E07E00E07E00E03C
-08E03C1CE07E1C70FF1C7FE7F83FC3F80F00E0161E7F9D1A> 38
-D<0038007800F001E003C007800F000E001C001C0038003800700070007000E000E000E0
-00E000E000E000E000E000E000E000700070007000380038001C001C000E000F00078003
-C001E000F8007800380D2878A21A> 40 D<6000F00078003C001E000F000780038001C0
-01C000E000E0007000700070003800380038003800380038003800380038003800700070
-007000E000E001C001C0038007800F001E003C007800F00060000D287CA21A> I<7FFFC0
-FFFFE0FFFFE07FFFC013047D901A> 45 D<00C001C001C003C007C00FC07FC0FDC071C0
-01C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C0
-7FFF7FFF7FFF101E7B9D1A> 49 D<03F8000FFE001FFF803C07C07801E07000E0E00070
-F00070F000706000700000700000700000E00000E00001C00003C0000780000F00001E00
-003C0000780000F00003E00007C0000F00001E00703C00707FFFF0FFFFF07FFFF0141E7D
-9D1A> I<03FC000FFF003FFFC03C03E07800E07800707800700000700000700000E00001
-E00007C003FF8003FF0003FFC00003E00000E0000070000078000038000038600038F000
-38F00078E000707000E07E03E03FFFC00FFF0001FC00151E7E9D1A> I<01FC0007FF001F
-FFC01F07C03C01E07800F07000707000707000707800F03800E01E03C00FFF8003FE0007
-FF001F8FC03C01E07800F0700070E00038E00038E00038E00038F000787000707800F03E
-03E01FFFC007FF0001FC00151E7E9D1A> 56 D<01F00007FC001FFE003E0F0038078070
-03807001C0E001C0E001C0E001E0E000E0E000E0E001E07001E07803E03C0FE01FFFE00F
-FCE003F0E00001C00001C00001C0000380600380F00700F00F00F03E007FFC003FF0000F
-C000131E7D9D1A> I<3078FCFC78300000000000000000003078FCFC7830061576941A>
-I<183C7E7E3C18000000000000000000183C7E7E3E1E0E0E1C3CF8F060071C77941A> I<
-0000C00003E00007E0000FC0003F80007E0000FC0003F80007E0000FC0003F80007E0000
-FC0000FC00007E00003F80000FC00007E00003F80000FC00007E00003F80000FC00007E0
-0003E00000C0131A7D9B1A> I<7FFFF0FFFFF8FFFFF87FFFF00000000000000000000000
-007FFFF0FFFFF8FFFFF87FFFF0150C7E941A> I<600000F80000FC00007E00003F80000F
-C00007E00003F80000FC00007E00003F80000FC00007E00007E0000FC0003F80007E0000
-FC0003F80007E0000FC0003F80007E0000FC0000F80000600000131A7D9B1A> I<007C38
-01FF3807FFF80F83F81E00F81C0078380078380038700038700038700000E00000E00000
-E00000E00000E00000E00000E00000E000007000007000387000383800383800381C0070
-1E00F00F83E007FFC001FF80007C00151E7E9D1A> 67 D<FE03FEFF03FEFF03FE1D8070
-1D80701DC0701CC0701CC0701CE0701CE0701C60701C70701C70701C30701C38701C3870
-1C18701C1C701C1C701C0C701C0E701C0E701C06701C06701C07701C03701C0370FF81F0
-FF81F0FF80F0171E7F9D1A> 78 D<03F8E00FFEE01FFFE03C07E07801E0F001E0E000E0
-E000E0E000E0E000007000007800003F80001FF80007FF00007FC00007E00000F0000070
-000038000038600038E00038E00038E00070F000F0FE01E0FFFFC0EFFF80E1FE00151E7E
-9D1A> 83 D<7FFFFEFFFFFEFFFFFEE0380EE0380EE0380EE0380E003800003800003800
-003800003800003800003800003800003800003800003800003800003800003800003800
-00380000380000380000380000380003FF8003FF8003FF80171E7F9D1A> I<FFFCFFFCFF
-FCE000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E0
-00E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000FFFCFFFCFF
-FC0E2776A21A> 91 D<FFFCFFFCFFFC001C001C001C001C001C001C001C001C001C001C
-001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C
-001C001C001C001C001CFFFCFFFCFFFC0E277FA21A> 93 D<1FF0003FFC007FFE00780F
-00300700000380000380007F8007FF801FFF803F8380780380700380E00380E00380E003
-80700780780F803FFFFC1FFDFC07F0FC16157D941A> 97 D<7E0000FE00007E00000E00
-000E00000E00000E00000E00000E00000E3E000EFF800FFFE00FC1F00F80700F00380E00
-380E001C0E001C0E001C0E001C0E001C0E001C0E001C0F00380F00780F80F00FC1E00FFF
-C00EFF80063E00161E7F9D1A> I<00FF8003FFC00FFFE01F01E03C00C078000070000070
-0000E00000E00000E00000E00000E000007000007000007800703C00701F01F00FFFE003
-FFC000FE0014157D941A> I<000FC0001FC0000FC00001C00001C00001C00001C00001C0
-0001C001F1C007FDC00FFFC01E0FC03C07C07803C07001C0E001C0E001C0E001C0E001C0
-E001C0E001C0E001C07003C07003C03807C03E0FC01FFFF807FDFC01F1F8161E7E9D1A>
-I<01F80007FF000FFF801E07C03C01C07800E07000E0E00070E00070FFFFF0FFFFF0FFFF
-F0E000007000007000007800703C00701F01F00FFFE003FF8000FE0014157D941A> I<00
-07E0001FF0003FF800787800F03000E00000E00000E00000E0007FFFF0FFFFF0FFFFF000
-E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000
-E00000E00000E0003FFF807FFFC03FFF80151E7F9D1A> I<7E0000FE00007E00000E0000
-0E00000E00000E00000E00000E00000E3E000EFF800FFFC00FC1C00F80E00F00E00E00E0
-0E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E07FC3FC
-FFE7FE7FC3FC171E7F9D1A> 104 D<00C00001E00001E00000C000000000000000000000
-0000000000000000007FE0007FE0007FE00000E00000E00000E00000E00000E00000E000
-00E00000E00000E00000E00000E00000E00000E00000E00000E0007FFF80FFFFC07FFF80
-121F7C9E1A> I<7FE000FFE0007FE00000E00000E00000E00000E00000E00000E00000E0
-0000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0
-0000E00000E00000E00000E00000E0007FFFC0FFFFE07FFFC0131E7D9D1A> 108
-D<7CE0E000FFFBF8007FFFF8001F1F1C001E1E1C001E1E1C001C1C1C001C1C1C001C1C1C
-001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C
-007F1F1F00FFBFBF807F1F1F00191580941A> I<7E3E00FEFF807FFFC00FC1C00F80E00F
-00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E
-00E07FC3FCFFE7FE7FC3FC17157F941A> I<01F00007FC001FFF003E0F803C07807803C0
-7001C0E000E0E000E0E000E0E000E0E000E0E000E0F001E07001C07803C03C07803E0F80
-1FFF0007FC0001F00013157D941A> I<7E3E00FEFF807FFFE00FC1F00F80700F00380E00
-380E001C0E001C0E001C0E001C0E001C0E001C0E001C0F00380F00780F80F00FC1E00FFF
-C00EFF800E3E000E00000E00000E00000E00000E00000E00000E00000E00007FC000FFE0
-007FC00016207F941A> I<7F81F8FF8FFC7F9FFE03FE1E03F80C03E00003E00003C00003
-80000380000380000380000380000380000380000380000380000380007FFF00FFFF007F
-FF0017157F941A> 114 D<07FB801FFF807FFF80780780E00380E00380E003807800007F
-C0001FFC0007FE00003F800007806001C0E001C0E001C0F003C0FC0780FFFF00EFFE00E3
-F80012157C941A> I<0180000380000380000380000380000380000380007FFFE0FFFFE0
-FFFFE0038000038000038000038000038000038000038000038000038000038000038070
-03807003807003807001C1E001FFE000FF80003F00141C7F9B1A> I<7E07E0FE0FE07E07
-E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00
-E00E00E00E01E00F03E007FFFC03FFFE00FCFC17157F941A> I<7F83FCFFC7FE7F83FC0E
-00E00E00E00E00E00701C00701C00701C003838003838003838001C70001C70001C70000
-EE0000EE0000EE00007C00007C0000380017157F941A> I<FF83FEFF83FEFF83FE380038
-3800381C00701C00701C00701C38701C7C701C7C700C6C600EEEE00EEEE00EEEE00EEEE0
-0EC6E006C6C007C7C00783C00783C017157F941A> I<7FC7F87FCFFC7FC7F80703C00383
-8003C70001EF0000FE00007C00007800003800007C0000EE0001EE0001C7000383800783
-C00F01C07FC7FCFFC7FE7FC7FC17157F941A> I<7F83FCFFC7FE7F83FC0E00E00E00E007
-00E00701C00701C00381C003838003C38001C38001C70000E70000E70000E60000660000
-6E00003C00003C00003C0000380000380000380000700000700030F00078E00071E0007F
-C0003F80001E000017207F941A> I<60F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0
-F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F060042775A21A> 124 D
-E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Ff cmr8 8 3
-/Ff 3 51 df<003000003000003000003000003000003000003000003000003000003000
-003000FFFFFCFFFFFC003000003000003000003000003000003000003000003000003000
-00300000300016187E931B> 43 D<06000E00FE000E000E000E000E000E000E000E000E
-000E000E000E000E000E000E000E000E000E00FFE00B157D9412> 49
-D<0F8030E040708030C038E0384038003800700070006000C00180030006000C08080810
-183FF07FF0FFF00D157E9412> I E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fg cmmi12 12 13
-/Fg 13 121 df<0FFFF81FFFFC3FFFF870200040200080200080600000600000600000C0
-0000C00000C00000C00001C0000180000180000380000380000380000700000300001615
-7E9415> 28 D<0000100000002000000020000000200000002000000040000000400000
-004000000040000000800000008000000080000000800000010000000FE00000711C0001
-C10600030203000E0203801C020180180201C0380401C0700401C0700401C0700401C0E0
-080380E0080380E00807006008070070100E0030101C00301038001C10E0000623800001
-FE0000002000000020000000400000004000000040000000400000008000000080000000
-800000008000001A2D7EA21D> 30 D<70F8F8F87005057C840E> 58
-D<70F8FCFC7404040404080810102040060F7C840E> I<00008000018000018000030000
-0300000300000600000600000600000C00000C00000C0000180000180000180000300000
-300000300000600000600000600000C00000C00000C00001800001800001800001800003
-00000300000300000600000600000600000C00000C00000C000018000018000018000030
-0000300000300000600000600000600000C00000C00000C0000011317DA418> 61
-D<00FFFC00000F8000000F0000000F0000001E0000001E0000001E0000001E0000003C00
-00003C0000003C0000003C00000078000000780000007800000078000000F0000000F000
-0000F0000000F0000001E0000001E0000001E0002001E0002003C0004003C0004003C000
-8003C0008007800180078001000780030007800F000F803E00FFFFFE001B227DA121> 76
-D<1FFFFFFE1E01E00E1801E0063001E0062003C0062003C0064003C0044003C004400780
-04800780048007800400078000000F0000000F0000000F0000000F0000001E0000001E00
-00001E0000001E0000003C0000003C0000003C0000003C00000078000000780000007800
-000078000000F0000000F0000000F0000000F0000001F000007FFFC0001F227EA11D> 84
-D<3FFE01FF8003C0003C0003C000300003C0001000078000200007800020000780002000
-07800020000F000040000F000040000F000040000F000040001E000080001E000080001E
-000080001E000080003C000100003C000100003C000100003C0001000078000200007800
-020000780002000078000200007000040000F000040000F0000800007000080000700010
-00007000200000380040000038008000001C01000000060600000001F800000021237DA1
-21> I<007E000381000700800E00801C0080380080780100700600FFF800F00000F00000
-E00000E00000E00000E00000E00080E000807003003004001838000FC00011157D9417>
-101 D<01E00FC001C001C001C0038003800380038007000700070007000E000E000E000E
-001C001C001C001C0038003800380038007000700070007080E100E100E100620062003C
-000B237EA20F> 108 D<03C0F004631C04740E08780E08700708700708700F00E00F00E0
-0F00E00F00E00F01C01E01C01E01C01E01C03C03803803803803C07003C0E0072180071E
-000700000700000E00000E00000E00000E00001C00001C00001C0000FF8000181F819418
-> 112 D<3C0F004630C04741C08783C08783C08701808700000E00000E00000E00000E00
-001C00001C00001C00001C000038000038000038000038000070000030000012157E9416
-> 114 D<01E0F006310C081A1C101A3C201C3C201C18201C000038000038000038000038
-0000700000700000700000700860E010F0E010F0E020E170404230803C1F0016157E941C
-> 120 D E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fh cmti12 12 22
-/Fh 22 122 df<FFF0FFF0FFE00C037C8B11> 45 D<70F8F8F0E005057A840F> I<00F8
-C00185C00705C00E03800E03801C03803C0380380700780700780700780700F00E00F00E
-00F00E00F00E10F01C20701C20703C20305C40308C400F078014157B9419> 97
-D<03C01F8003800380038007000700070007000E000E000E000E001C001CF81D0C1E0E3C
-0638073807380F700F700F700F700FE01EE01EE01EE03CE038E038607060E031C01F0010
-237BA216> I<007E0001C1000301800703800E07801C07803C0000380000780000780000
-780000F00000F00000F00000F00000F00100700100700200300C001830000FC00011157B
-9416> I<00003C0003F80000380000380000380000700000700000700000700000E00000
-E00000E00000E00001C000F9C00185C00705C00E03800E03801C03803C03803807007807
-00780700780700F00E00F00E00F00E00F00E10F01C20701C20703C20305C40308C400F07
-8016237BA219> I<00F803840E021C023C0238027804F018FFE0F000F000E000E000E000
-E000E002E0026004701830600F800F157A9416> I<00003E0000470000CF00018F000186
-000380000380000380000700000700000700000700000700000E0000FFF0000E00000E00
-000E00001C00001C00001C00001C00001C00003800003800003800003800003800007000
-00700000700000700000700000E00000E00000E00000E00000C00001C00001C000718000
-F18000F300006200003C0000182D82A20F> I<001F180030B800E0B801C07001C0700380
-700780700700E00F00E00F00E00F00E01E01C01E01C01E01C01E01C01E03800E03800E07
-80060B8006170001E700000700000700000E00000E00000E00701C00F01800F0300060E0
-003F8000151F7E9416> I<00C001E001C001C0000000000000000000000000000000001E
-002300430043008700870087000E000E001C001C001C0038003800384070807080708071
-0032001C000B217BA00F> 105 D<00F00007E00000E00000E00000E00001C00001C00001
-C00001C0000380000380000380000380000700000701E00702100704700E08F00E10F00E
-20600E40001D80001E00001FC0001C7000383800383800381C00381C2070384070384070
-3840701880E01880600F0014237DA216> 107 D<01E00FC001C001C001C0038003800380
-038007000700070007000E000E000E000E001C001C001C001C0038003800380038007000
-700070007100E200E200E200E200640038000B237CA20C> I<1C0F80F8002610C10C0047
-6066060087807807008780780700870070070087007007000E00E00E000E00E00E000E00
-E00E000E00E00E001C01C01C001C01C01C001C01C01C001C01C038203803803840380380
-70403803807080380380308070070031003003001E0023157B9428> I<380F804C30C04E
-40608E80708F00708E00708E00701C00E01C00E01C00E01C00E03801C03801C03801C038
-0384700388700308700708700310E003106001E016157B941B> I<007E0001C300038180
-0701C00E01C01C01E03C01E03801E07801E07801E07801E0F003C0F003C0F00380F00780
-700700700E00700C0030180018700007C00013157B9419> I<01C1F002621804741C0878
-0C08700E08700E08701E00E01E00E01E00E01E00E01E01C03C01C03C01C03C01C0780380
-7003807003C0E003C1C0072380071E000700000700000E00000E00000E00000E00001C00
-001C00001C0000FFC000171F7F9419> I<1C1F002620804741C08783C08703C087018087
-00000E00000E00000E00000E00001C00001C00001C00001C000038000038000038000038
-000070000030000012157B9415> 114 D<00FC000183000200800401800C03800C03000C
-00000F00000FF00007FC0003FE00003E00000F00000700700700F00600F00600E0040040
-08002030001FC00011157D9414> I<00C001C001C001C001C003800380038003800700FF
-F8070007000E000E000E000E001C001C001C001C00380038003800381070207020704070
-8031001E000D1F7C9E10> I<1E0060E02300E0F04380E1F04381C0F08381C0708701C030
-8701C030070380200E0380200E0380200E0380201C0700401C0700401C0700401C070080
-1C0700801C0701001C0F01000C0B02000613840003E0F8001C157B9420> 119
-D<03C1E0046210083470103CF02038F020386020380000700000700000700000700000E0
-0000E00000E00000E02061C040F1C040F1C080E2C100446200383C0014157D9416> I<1E
-00302300704380704380E08380E08700E08700E00701C00E01C00E01C00E01C01C03801C
-03801C03801C03801C07001C07001C07001C0F000C3E0003CE00000E00000E00001C0060
-1C00F03800F03000E0600080C0004380003E0000141F7B9418> I
-E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fi cmbx12 12 20
-/Fi 20 122 df<FFFFFF8000FFFFFFF00007F003FC0007F0007E0007F0003F0007F0001F
-8007F0000FC007F00007E007F00007E007F00007F007F00003F007F00003F007F00003F0
-07F00003F807F00003F807F00003F807F00003F807F00003F807F00003F807F00003F807
-F00003F807F00003F807F00003F007F00003F007F00003F007F00007E007F00007E007F0
-000FC007F0001F8007F0003F0007F0007E0007F003FC00FFFFFFF000FFFFFF800025227E
-A12B> 68 D<01FE0207FF861F01FE3C007E7C001E78000E78000EF80006F80006FC0006
-FC0000FF0000FFE0007FFF007FFFC03FFFF01FFFF80FFFFC03FFFE003FFE0003FE00007F
-00003F00003FC0001FC0001FC0001FE0001EE0001EF0003CFC003CFF00F8C7FFE080FF80
-18227DA11F> 83 D<7FFFFFFF807FFFFFFF807E03F80F807803F807807003F803806003
-F80180E003F801C0E003F801C0C003F800C0C003F800C0C003F800C0C003F800C00003F8
-00000003F800000003F800000003F800000003F800000003F800000003F800000003F800
-000003F800000003F800000003F800000003F800000003F800000003F800000003F80000
-0003F800000003F800000003F800000003F800000003F8000001FFFFF00001FFFFF00022
-227EA127> I<0FFC003FFF807E07C07E03E07E01E07E01F03C01F00001F00001F0003FF0
-03FDF01FC1F03F01F07E01F0FC01F0FC01F0FC01F0FC01F07E02F07E0CF81FF87F07E03F
-18167E951B> 97 D<FF000000FF0000001F0000001F0000001F0000001F0000001F0000
-001F0000001F0000001F0000001F0000001F0000001F0000001F0FE0001F3FF8001FE07C
-001F803E001F001F001F000F801F000F801F000FC01F000FC01F000FC01F000FC01F000F
-C01F000FC01F000FC01F000FC01F000F801F001F801F801F001FC03E001EE07C001C3FF8
-00180FC0001A237EA21F> I<00FF8007FFE00F83F01F03F03E03F07E03F07C01E07C0000
-FC0000FC0000FC0000FC0000FC0000FC00007C00007E00007E00003E00181F00300FC060
-07FFC000FF0015167E9519> I<00FE0007FF800F87C01E01E03E01F07C00F07C00F8FC00
-F8FC00F8FFFFF8FFFFF8FC0000FC0000FC00007C00007C00007E00003E00181F00300FC0
-7003FFC000FF0015167E951A> 101 D<001FC0007FE000F1F001E3F003E3F007C3F007C1
-E007C00007C00007C00007C00007C00007C000FFFE00FFFE0007C00007C00007C00007C0
-0007C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007C0
-0007C00007C0003FFC003FFC00142380A211> I<01FE0F0007FFBF800F87C7801F03E780
-1E01E0003E01F0003E01F0003E01F0003E01F0003E01F0001E01E0001F03E0000F87C000
-0FFF800009FE000018000000180000001C0000001FFFE0000FFFF80007FFFE001FFFFF00
-3C003F0078000F80F0000780F0000780F0000780F000078078000F003C001E001F007C00
-0FFFF80001FFC00019217F951C> I<1C003E007F007F007F003E001C0000000000000000
-00000000000000FF00FF001F001F001F001F001F001F001F001F001F001F001F001F001F
-001F001F001F001F001F00FFE0FFE00B247EA310> 105 D<FF00FF001F001F001F001F00
-1F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F00
-1F001F001F001F001F001F001F001F001F00FFE0FFE00B237EA210> 108
-D<FF07F007F000FF1FFC1FFC001F303E303E001F403E403E001F801F801F001F801F801F
-001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F
-001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F
-001F001F001F001F001F001F00FFE0FFE0FFE0FFE0FFE0FFE02B167E9530> I<FF07E000
-FF1FF8001F307C001F403C001F803E001F803E001F003E001F003E001F003E001F003E00
-1F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E00
-1F003E00FFE1FFC0FFE1FFC01A167E951F> I<00FE0007FFC00F83E01E00F03E00F87C00
-7C7C007C7C007CFC007EFC007EFC007EFC007EFC007EFC007EFC007E7C007C7C007C3E00
-F81F01F00F83E007FFC000FE0017167E951C> I<FF0FE000FF3FF8001FE07C001F803E00
-1F001F001F001F801F001F801F000FC01F000FC01F000FC01F000FC01F000FC01F000FC0
-1F000FC01F000FC01F001F801F001F801F803F001FC03E001FE0FC001F3FF8001F0FC000
-1F0000001F0000001F0000001F0000001F0000001F0000001F0000001F000000FFE00000
-FFE000001A207E951F> I<0FF3003FFF00781F00600700E00300E00300F00300FC00007F
-E0007FF8003FFE000FFF0001FF00000F80C00780C00380E00380E00380F00700FC0E00EF
-FC00C7F00011167E9516> 115 D<01800001800001800001800003800003800007800007
-80000F80003F8000FFFF00FFFF000F80000F80000F80000F80000F80000F80000F80000F
-80000F80000F80000F80000F81800F81800F81800F81800F81800F830007C30003FE0000
-F80011207F9F16> I<FF01FE00FF01FE001F003E001F003E001F003E001F003E001F003E
-001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E
-001F003E001F007E001F00FE000F81BE0007FF3FC001FC3FC01A167E951F> I<FFE07FC0
-FFE07FC00F801C0007C0380003E0700003F0600001F8C00000F98000007F8000003F0000
-001F0000001F8000003FC0000037C0000063E00000C1F00001C0F8000380FC0007007E00
-0E003E00FF80FFE0FF80FFE01B167F951E> 120 D<FFE01FE0FFE01FE01F8007000F8006
-000FC00E0007C00C0007E00C0003E0180003E0180001F0300001F0300000F8600000F860
-00007CC000007CC000007FC000003F8000003F8000001F0000001F0000000E0000000E00
-00000C0000000C00000018000078180000FC380000FC300000FC60000069C000007F8000
-001F0000001B207F951E> I E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fj cmsy10 12 15
-/Fj 15 107 df<FFFFFFFCFFFFFFFC1E027C8C27> 0 D<03F0000FFC001FFE003FFF007F
-FF807FFF80FFFFC0FFFFC0FFFFC0FFFFC0FFFFC0FFFFC0FFFFC0FFFFC07FFF807FFF803F
-FF001FFE000FFC0003F00012147D9519> 15 D<000FFFFC007FFFFC01F0000003800000
-060000000C0000001800000030000000300000006000000060000000C0000000C0000000
-C0000000C0000000C0000000C0000000C0000000C0000000600000006000000030000000
-30000000180000000C000000060000000380000001E00000007FFFFC001FFFFC1E1E7C9A
-27> 26 D<00000001800000000001800000000001800000000001800000000000C00000
-000000C000000000006000000000003000000000003000000000001C00000000000E0000
-0000000700FFFFFFFFFFE0FFFFFFFFFFE0000000000700000000000E00000000001C0000
-000000300000000000300000000000600000000000C00000000000C00000000001800000
-00000180000000000180000000000180002B1A7D9832> 33 D<001FFF007FFF01E00003
-80000600000C0000180000300000300000600000600000600000C00000C00000FFFFFFFF
-FFFFC00000C000006000006000006000003000003000001800000C000006000003800001
-E000007FFF001FFF181E7C9A21> 50 D<00000300000300000600000600000C00000C00
-00180000180000300000300000600000600000C00000C00000C000018000018000030000
-0300000600000600000C00000C0000180000180000300000300000600000600000C00000
-C0000180000180000300000300000300000600000600000C00000C000018000018000030
-0000300000600000600000C00000400000183079A300> 54 D<C0C0C0C0C0C0C0C0E0E0
-C0C0C0C0C0C0C0C003127D9400> I<00008000018001F980070F000C0300180380180780
-3006C03006C0700CE0600C60600C60600C60E01870E01870E01870E03070E03070E03070
-E06070E06070E06070E06070E0C070E0C070E0C070E18070E180706180606300607300E0
-7300E03300C03600C01E01801E01800C03000F0E000DF800180000180000180000142A7E
-A519> 59 D<000100000003000000030000000300000003000000030000000300000003
-000000030000000300000003000000030000000300000003000000030000000300000003
-000000030000000300000003000000030000000300000003000000030000000300000003
-000000030000000300000003000000030000FFFFFFFEFFFFFFFE1F207C9F27> 63
-D<40000040C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000
-C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000
-C0C00000C0C00000C0C00000C0C00000C0C00000C0600001806000018030000300180006
-000E001C000780780001FFE000007F80001A1F7D9D21> 91 D<007F800001FFE0000780
-78000E001C0018000600300003006000018060000180C00000C0C00000C0C00000C0C000
-00C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C000
-00C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C000
-00C0400000401A1F7D9D21> I<000C0000000C0000001E0000001E0000001E0000003300
-0000330000006180000061800000C0C00000C0C00000C0C0000180600001806000030030
-00030030000300300006001800060018000C000C000C000C000C000C0018000600180006
-003000030030000300600001806000018060000180C00000C0C00000401A1F7D9D21> 94
-D<0003C0001E0000380000700000E00000E00000E00000E00000E00000E00000E00000E0
-0000E00000E00000E00000E00000E00000E00000E00000E00000E00001C0000380000F00
-00F800000F000003800001C00000E00000E00000E00000E00000E00000E00000E00000E0
-0000E00000E00000E00000E00000E00000E00000E00000E00000E000007000003800001E
-000003C012317DA419> 102 D<F800000F000003800001C00000E00000E00000E00000E0
-0000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0
-0000E000007000003800001E000003C0001E0000380000700000E00000E00000E00000E0
-0000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0
-0000E00001C0000380000F0000F8000012317DA419> I<C0C0C0C0C0C0C0C0C0C0C0C0C0
-C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0
-02317AA40E> 106 D E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fk cmr12 12 65
-/Fk 65 125 df<001FC1F00070371800C03E3C01807C3C0380783C070038000700380007
-003800070038000700380007003800070038000700380007003800FFFFFFC00700380007
-003800070038000700380007003800070038000700380007003800070038000700380007
-0038000700380007003800070038000700380007003800070038000700380007003C007F
-E1FFC01E2380A21C> 11 D<001FC0000070200000C01000018038000380780007007800
-0700300007000000070000000700000007000000070000000700000007000000FFFFF800
-070078000700380007003800070038000700380007003800070038000700380007003800
-070038000700380007003800070038000700380007003800070038000700380007003800
-070038007FE1FF80192380A21B> I<001FD8000070380000C07800018078000380780007
-0038000700380007003800070038000700380007003800070038000700380007003800FF
-FFF800070038000700380007003800070038000700380007003800070038000700380007
-003800070038000700380007003800070038000700380007003800070038000700380007
-003800070038007FF3FF80192380A21B> I<000FC07F00007031C08000E00B004001801E
-00E003803E01E007003C01E007001C00C007001C000007001C000007001C000007001C00
-0007001C000007001C000007001C0000FFFFFFFFE007001C01E007001C00E007001C00E0
-07001C00E007001C00E007001C00E007001C00E007001C00E007001C00E007001C00E007
-001C00E007001C00E007001C00E007001C00E007001C00E007001C00E007001C00E00700
-1C00E007001C00E07FF1FFCFFE272380A229> I<70F8FCFC740404040408081010204006
-0F7CA20E> 39 D<00200040008001000300060004000C000C0018001800300030003000
-7000600060006000E000E000E000E000E000E000E000E000E000E000E000E000E000E000
-6000600060007000300030003000180018000C000C000400060003000100008000400020
-0B327CA413> I<800040002000100018000C000400060006000300030001800180018001
-C000C000C000C000E000E000E000E000E000E000E000E000E000E000E000E000E000E000
-C000C000C001C0018001800180030003000600060004000C00180010002000400080000B
-327DA413> I<70F8FCFC7404040404080810102040060F7C840E> 44
-D<FFF8FFF80D02808B10> I<70F8F8F87005057C840E> I<01F000071C000C0600180300
-3803803803807001C07001C07001C07001C0F001E0F001E0F001E0F001E0F001E0F001E0
-F001E0F001E0F001E0F001E0F001E0F001E0F001E0F001E07001C07001C07001C07803C0
-3803803803801C07000C0600071C0001F00013227EA018> 48 D<008003800F80F38003
-800380038003800380038003800380038003800380038003800380038003800380038003
-800380038003800380038003800380038007C0FFFE0F217CA018> I<03F0000C1C001007
-002007804003C04003C08003E0F003E0F801E0F801E0F801E02003E00003E00003C00003
-C0000780000700000E00001C0000180000300000600000C0000180000100000200200400
-200800201800603000403FFFC07FFFC0FFFFC013217EA018> I<03F8000C1E00100F0020
-07804007C07807C07803C07807C03807C0000780000780000700000F00000C0000380003
-F000001C00000F000007800007800003C00003C00003E02003E07003E0F803E0F803E0F0
-03C04003C0400780200780100F000C1C0003F00013227EA018> I<000300000300000700
-000700000F00001700001700002700006700004700008700018700010700020700060700
-040700080700080700100700200700200700400700C00700FFFFF8000700000700000700
-000700000700000700000700000F80007FF015217FA018> I<70F8F8F870000000000000
-000000000070F8F8F87005157C940E> 58 D<FFFFFFFEFFFFFFFE000000000000000000
-0000000000000000000000000000000000000000000000FFFFFFFEFFFFFFFE1F0C7D9126
-> 61 D<07E01838201C400E800FF00FF00FF00F000F000E001C00380030006000C000C0
-00800080018001000100010001000100010000000000000000000000038007C007C007C0
-038010237DA217> 63 D<0001800000018000000180000003C0000003C0000003C00000
-05E0000005E0000009F0000008F0000008F00000107800001078000010780000203C0000
-203C0000203C0000401E0000401E0000C01F0000800F0000800F0001FFFF800100078001
-000780020003C0020003C0020003C0040001E0040001E0040001E0080000F01C0000F03E
-0001F8FF800FFF20237EA225> 65 D<FFFFF8000F800E0007800780078003C0078003E0
-078001E0078001F0078001F0078001F0078001F0078001F0078001E0078003E0078007C0
-07800F8007803E0007FFFE0007800780078003C0078001E0078001F0078000F0078000F8
-078000F8078000F8078000F8078000F8078000F8078001F0078001F0078003E0078007C0
-0F800F00FFFFFC001D227EA123> I<0007E0100038183000E0063001C00170038000F007
-0000F00E0000701E0000701C0000303C0000303C0000307C0000107800001078000010F8
-000000F8000000F8000000F8000000F8000000F8000000F8000000F80000007800000078
-0000107C0000103C0000103C0000101C0000201E0000200E000040070000400380008001
-C0010000E0020000381C000007E0001C247DA223> I<FFFFF0000F801E00078007000780
-0380078001C0078000E0078000F007800078078000780780007C0780003C0780003C0780
-003C0780003E0780003E0780003E0780003E0780003E0780003E0780003E0780003E0780
-003E0780003C0780003C0780007C0780007807800078078000F0078000E0078001E00780
-03C0078007000F801E00FFFFF0001F227EA125> I<FFFFFFC00F8007C0078001C0078000
-C00780004007800040078000600780002007800020078000200780202007802000078020
-0007802000078060000780E00007FFE0000780E000078060000780200007802000078020
-000780200007800000078000000780000007800000078000000780000007800000078000
-00078000000FC00000FFFE00001B227EA120> 70 D<0007F008003C0C1800E0021801C0
-01B8038000F8070000780F0000381E0000381E0000183C0000183C0000187C0000087800
-000878000008F8000000F8000000F8000000F8000000F8000000F8000000F8000000F800
-1FFF780000F8780000787C0000783C0000783C0000781E0000781E0000780F0000780700
-0078038000B801C000B800E00318003C0C080007F00020247DA226> I<FFFC3FFF0FC003
-F0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001
-E0078001E0078001E0078001E0078001E0078001E007FFFFE0078001E0078001E0078001
-E0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001
-E0078001E0078001E0078001E00FC003F0FFFC3FFF20227EA125> I<FFFC0FC007800780
-078007800780078007800780078007800780078007800780078007800780078007800780
-07800780078007800780078007800780078007800FC0FFFC0E227EA112> I<FFFC00FF80
-0FC0007C0007800030000780002000078000400007800080000780010000078002000007
-80040000078008000007801000000780200000078040000007808000000781C000000783
-E000000785E000000788F000000790F0000007A078000007C03C000007803C000007801E
-000007800F000007800F00000780078000078007C000078003C000078001E000078001E0
-00078000F000078000F8000FC000FC00FFFC07FF8021227EA126> 75
-D<FFFC001F80000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00
-000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00010F00
-010F00010F00010F00030F00030F00020F00060F00060F001E1F007EFFFFFE18227DA11E
-> I<FF8007FF07C000F807C0007005E0002004F0002004F0002004780020047C0020043C
-0020041E0020041F0020040F002004078020040780200403C0200401E0200401E0200400
-F0200400F8200400782004003C2004003E2004001E2004000F2004000F20040007A00400
-03E0040003E0040001E0040001E0040000E00E0000601F000060FFE0002020227EA125>
-78 D<000FE00000783C0000E00E0003C00780078003C00F0001E00E0000E01E0000F03C
-0000783C0000787C00007C7C00007C7800003C7800003CF800003EF800003EF800003EF8
-00003EF800003EF800003EF800003EF800003EF800003E7800003C7C00007C7C00007C3C
-0000783E0000F81E0000F00F0001E00F0001E0078003C003C0078000E00E0000783C0000
-0FE0001F247DA226> I<FFFFF0000F803C0007800F0007800780078007C0078003C00780
-03E0078003E0078003E0078003E0078003E0078003E0078003C0078007C0078007800780
-0F0007803C0007FFF0000780000007800000078000000780000007800000078000000780
-0000078000000780000007800000078000000780000007800000078000000FC00000FFFC
-00001B227EA121> I<FFFFE000000F803C000007800E00000780078000078007C0000780
-03C000078003E000078003E000078003E000078003E000078003E000078003C000078007
-C000078007800007800E000007803C000007FFE000000780700000078038000007801C00
-0007801E000007800E000007800F000007800F000007800F000007800F000007800F8000
-07800F800007800F800007800F808007800FC080078007C0800FC003C100FFFC01E20000
-00007C0021237EA124> 82 D<03F0200C0C601802603001E07000E0600060E00060E000
-60E00020E00020E00020F00000F000007800007F00003FF0001FFE000FFF0003FF80003F
-C00007E00001E00000F00000F0000070800070800070800070800070C00060C00060E000
-C0F000C0C80180C6070081FC0014247DA21B> I<7FFFFFF8780780786007801840078008
-4007800840078008C007800C800780048007800480078004800780040007800000078000
-000780000007800000078000000780000007800000078000000780000007800000078000
-000780000007800000078000000780000007800000078000000780000007800000078000
-00078000000FC00001FFFE001E227EA123> I<FFF0007FC01F80001F000F00000C000F80
-000C000780000800078000080003C000100003C000100003C000100001E000200001E000
-200001F000600000F000400000F000400000780080000078008000007C008000003C0100
-00003C010000001E020000001E020000001E020000000F040000000F040000000F8C0000
-000788000000078800000003D000000003D000000003F000000001E000000001E0000000
-00C000000000C000000000C0000022237FA125> 86 D<FFF03FFC03FE1F8007E000F80F
-0003C000700F0003C000200F0001E00020078001E00040078001E00040078003F0004003
-C002F0008003C002F0008003C002F0008003E00478018001E00478010001E00478010001
-E0083C010000F0083C020000F0083C020000F0101E02000078101E04000078101E040000
-78200F0400003C200F0800003C200F0800003C600F8800001E40079000001E4007900000
-1E4007D000001F8003F000000F8003E000000F8003E000000F0001E00000070001C00000
-070001C00000060000C0000002000080002F237FA132> I<FEFEC0C0C0C0C0C0C0C0C0C0
-C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0FE
-FE07317BA40E> 91 D<FEFE060606060606060606060606060606060606060606060606
-060606060606060606060606060606060606060606FEFE07317FA40E> 93
-D<1FE000303800780C00780E0030070000070000070000070000FF0007C7001E07003C07
-00780700700700F00708F00708F00708F00F087817083C23900FC1E015157E9418> 97
-D<0E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00000E00000E00
-000E00000E00000E1F000E61C00E80600F00300E00380E003C0E001C0E001E0E001E0E00
-1E0E001E0E001E0E001E0E001E0E001C0E003C0E00380F00700C80600C41C0083F001723
-7FA21B> I<01FE000703000C07801C0780380300780000700000F00000F00000F00000F0
-0000F00000F00000F000007000007800403800401C00800C010007060001F80012157E94
-16> I<0000E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00000E0
-0000E00000E00000E001F8E00704E00C02E01C01E03800E07800E07000E0F000E0F000E0
-F000E0F000E0F000E0F000E0F000E07000E07800E03800E01801E00C02E0070CF001F0FE
-17237EA21B> I<01FC000707000C03801C01C03801C07801E07000E0F000E0FFFFE0F000
-00F00000F00000F00000F000007000007800203800201C00400E008007030000FC001315
-7F9416> I<003E0000E30001C78003878003078007000007000007000007000007000007
-0000070000070000070000FFF80007000007000007000007000007000007000007000007
-00000700000700000700000700000700000700000700000700000700000700000780007F
-F000112380A20F> I<00007003F1980E1E181C0E18380700380700780780780780780780
-7807803807003807001C0E001E1C0033F0002000002000003000003800003FFE001FFFC0
-0FFFE03000F0600030C00018C00018C00018C000186000306000303800E00E038003FE00
-15217F9518> I<0E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00
-000E00000E00000E00000E00000E1F800E60C00E80E00F00700F00700E00700E00700E00
-700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00
-70FFE7FF18237FA21B> I<1C003E003E003E001C00000000000000000000000000000000
-000E007E001E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E
-000E000E00FFC00A227FA10E> I<00E001F001F001F000E0000000000000000000000000
-00000000007007F000F00070007000700070007000700070007000700070007000700070
-00700070007000700070007000700070007000706070F0E0F0C061803F000C2C83A10F>
-I<0E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00000E00000E00
-000E00000E00000E03FC0E01F00E01C00E01800E02000E04000E08000E10000E38000EF8
-000F1C000E1E000E0E000E07000E07800E03C00E01C00E01E00E00F00E00F8FFE3FE1723
-7FA21A> I<0E00FE001E000E000E000E000E000E000E000E000E000E000E000E000E000E
-000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E
-00FFE00B237FA20E> I<0E1FC07F00FE60E183801E807201C00F003C00E00F003C00E00E
-003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E00
-3800E00E003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E0038
-00E0FFE3FF8FFE27157F942A> I<0E1F80FE60C01E80E00F00700F00700E00700E00700E
-00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E
-0070FFE7FF18157F941B> I<01FC000707000C01801800C03800E0700070700070F00078
-F00078F00078F00078F00078F00078F000787000707800F03800E01C01C00E0380070700
-01FC0015157F9418> I<0E1F00FE61C00E80600F00700E00380E003C0E003C0E001E0E00
-1E0E001E0E001E0E001E0E001E0E001E0E003C0E003C0E00380F00700E80E00E41C00E3F
-000E00000E00000E00000E00000E00000E00000E00000E00000E0000FFE000171F7F941B
-> I<01F8200704600E02601C01603801E07800E07800E0F000E0F000E0F000E0F000E0F0
-00E0F000E0F000E07800E07800E03801E01C01E00C02E0070CE001F0E00000E00000E000
-00E00000E00000E00000E00000E00000E00000E0000FFE171F7E941A> I<0E3CFE461E8F
-0F0F0F060F000E000E000E000E000E000E000E000E000E000E000E000E000E000F00FFF0
-10157F9413> I<0F8830786018C018C008C008E008F0007F003FE00FF001F8003C801C80
-0C800CC00CC008E018D0308FC00E157E9413> I<02000200020002000600060006000E00
-1E003E00FFFC0E000E000E000E000E000E000E000E000E000E000E000E040E040E040E04
-0E040E040708030801F00E1F7F9E13> I<0E0070FE07F01E00F00E00700E00700E00700E
-00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00F00E00F006
-017003827800FC7F18157F941B> I<FF80FE1E00781E00300E00200E0020070040070040
-0780C003808003808001C10001C10000E20000E20000E200007400007400003800003800
-00380000100017157F941A> I<FF8FF87F3E01E03C1C01C0181C01E0180E01E0100E0260
-100E027010070270200704302007043820038438400388184003881C4001C81C8001D00C
-8001D00E8000F00F0000E0070000E00700006006000040020020157F9423> I<FF83FE1F
-00F00E00C007008007810003830001C20000E400007800007800003800003C00004E0000
-8F000187000103800201C00401E00C00E03E01F0FF03FE17157F941A> I<FF80FE1E0078
-1E00300E00200E00200700400700400780C003808003808001C10001C10000E20000E200
-00E200007400007400003800003800003800001000001000002000002000002000004000
-F04000F08000F180004300003C0000171F7F941A> I<3FFFC0380380300780200700600E
-00401C00403C0040380000700000E00001E00001C0000380400700400F00400E00C01C00
-80380080780180700780FFFF8012157F9416> I<FFFFFFFFFFFF3001808C31> 124
-D E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fl cmbx12 14.4 19
-/Fl 19 118 df<00007FE0030007FFFC07001FFFFF0F007FF00F9F00FF0001FF01FC0000
-FF03F800007F07F000003F0FE000001F1FC000001F1FC000000F3F8000000F3F80000007
-7F800000077F800000077F00000000FF00000000FF00000000FF00000000FF00000000FF
-00000000FF00000000FF00000000FF00000000FF000000007F000000007F800000007F80
-0000073F800000073F800000071FC00000071FC000000E0FE000000E07F000001C03F800
-003C01FC00007800FF0001F0007FF007C0001FFFFF800007FFFE0000007FF00028297CA8
-31> 67 D<FFFFFC0000FFFFFC0000FFFFFC000003FC00000003FC00000003FC00000003
-FC00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC
-00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC00
-000003FC00000003FC00000003FC00000003FC0001C003FC0001C003FC0001C003FC0001
-C003FC0003C003FC00038003FC00038003FC00078003FC00078003FC000F8003FC000F80
-03FC001F8003FC007F8003FC01FF00FFFFFFFF00FFFFFFFF00FFFFFFFF0022297EA828>
-76 D<0000FFC00000000FFFFC0000003F807F000000FE001FC00001F80007E00003F000
-03F00007E00001F8000FE00001FC001FC00000FE001FC00000FE003F8000007F003F8000
-007F007F8000007F807F0000003F807F0000003F807F0000003F80FF0000003FC0FF0000
-003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000
-003FC0FF0000003FC0FF0000003FC07F0000003F807F8000007F807F8000007F803F8000
-007F003F8000007F001FC00000FE001FC00000FE000FE00001FC0007F00003F80003F800
-07F00001FC000FE00000FE001FC000003FC0FF0000000FFFFC00000000FFC000002A297C
-A833> 79 D<FFFFF0007FFFFFFFF0007FFFFFFFF0007FFF03FE000001C001FE00000380
-01FE0000038001FF0000078000FF0000070000FF80000F00007F80000E00007FC0000E00
-003FC0001C00003FC0001C00003FE0003C00001FE0003800001FF0007800000FF0007000
-000FF80070000007F800E0000007F800E0000003FC01C0000003FC01C0000003FE03C000
-0001FE0380000001FF0780000000FF0700000000FF87000000007F8E000000007F8E0000
-00007FDE000000003FDC000000003FFC000000001FF8000000001FF8000000000FF00000
-00000FF0000000000FF00000000007E00000000007E00000000003C00000000003C00000
-30297FA833> 86 D<03FF80000FFFF0001F01FC003F80FE003F807F003F803F003F803F
-801F003F8000003F8000003F8000003F8000003F80003FFF8001FC3F800FE03F801F803F
-803F003F807E003F80FC003F80FC003F80FC003F80FC003F80FC005F807E00DF803F839F
-FC1FFE0FFC03FC03FC1E1B7E9A21> 97 D<FFE00000FFE00000FFE000000FE000000FE0
-00000FE000000FE000000FE000000FE000000FE000000FE000000FE000000FE000000FE0
-00000FE000000FE1FE000FEFFF800FFE07E00FF803F00FF001F80FE000FC0FE000FC0FE0
-007E0FE0007E0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0
-007F0FE0007E0FE0007E0FE0007E0FE000FC0FE000FC0FF001F80FF803F00F9C0FE00F0F
-FF800E01FC00202A7EA925> I<00007FF000007FF000007FF0000007F0000007F0000007
-F0000007F0000007F0000007F0000007F0000007F0000007F0000007F0000007F0000007
-F0003F87F001FFF7F007F03FF00FC00FF01F8007F03F0007F03F0007F07E0007F07E0007
-F07E0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007
-F07E0007F07E0007F03F0007F03F0007F01F800FF00FC01FF007E07FFF01FFE7FF007F87
-FF202A7EA925> 100 D<003FC00001FFF00003E07C000F803E001F801F001F001F003F00
-0F807E000F807E000FC07E000FC0FE0007C0FE0007C0FFFFFFC0FFFFFFC0FE000000FE00
-0000FE0000007E0000007E0000007F0000003F0001C01F0001C00F80038007C0070003F0
-1E0000FFFC00003FE0001A1B7E9A1F> I<0007F8003FFC007E3E01FC7F03F87F03F07F07
-F07F07F03E07F00007F00007F00007F00007F00007F00007F000FFFFC0FFFFC0FFFFC007
-F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007
-F00007F00007F00007F00007F00007F00007F00007F00007F0007FFF807FFF807FFF8018
-2A7EA915> I<FFE00000FFE00000FFE000000FE000000FE000000FE000000FE000000FE0
-00000FE000000FE000000FE000000FE000000FE000000FE000000FE000000FE07E000FE1
-FF800FE30FC00FE40FE00FE807E00FF807F00FF007F00FF007F00FE007F00FE007F00FE0
-07F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE0
-07F00FE007F00FE007F00FE007F00FE007F0FFFE3FFFFFFE3FFFFFFE3FFF202A7DA925>
-104 D<07000F801FC03FE03FE03FE01FC00F8007000000000000000000000000000000FF
-E0FFE0FFE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00F
-E00FE00FE00FE00FE00FE0FFFEFFFEFFFE0F2B7EAA12> I<FFE0FFE0FFE00FE00FE00FE0
-0FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE0
-0FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE0FFFEFFFEFFFE
-0F2A7EA912> 108 D<FFC07E00FFC1FF80FFC30FC00FC40FE00FC807E00FD807F00FD007
-F00FD007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007
-F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F0FFFE3F
-FFFFFE3FFFFFFE3FFF201B7D9A25> 110 D<003FE00001FFFC0003F07E000FC01F801F80
-0FC03F0007E03F0007E07E0003F07E0003F07E0003F0FE0003F8FE0003F8FE0003F8FE00
-03F8FE0003F8FE0003F8FE0003F8FE0003F87E0003F07E0003F03F0007E03F0007E01F80
-0FC00FC01F8007F07F0001FFFC00003FE0001D1B7E9A22> I<FFE1FE00FFEFFF80FFFE0F
-E00FF803F00FF001F80FE001FC0FE000FC0FE000FE0FE000FE0FE0007F0FE0007F0FE000
-7F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007E0FE000FE0FE000FE0FE000
-FC0FE001FC0FF001F80FF807F00FFC0FE00FEFFF800FE1FC000FE000000FE000000FE000
-000FE000000FE000000FE000000FE000000FE000000FE00000FFFE0000FFFE0000FFFE00
-0020277E9A25> I<FFC1F0FFC7FCFFC63E0FCC7F0FD87F0FD07F0FD07F0FF03E0FE0000F
-E0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000F
-E0000FE0000FE000FFFF00FFFF00FFFF00181B7F9A1B> 114 D<03FE300FFFF03E03F078
-00F07000F0F00070F00070F80070FE0000FFE0007FFF007FFFC03FFFE01FFFF007FFF800
-FFF80007FC0000FCE0007CE0003CF0003CF00038F80038FC0070FF01E0E7FFC0C1FF0016
-1B7E9A1B> I<00E00000E00000E00000E00001E00001E00001E00003E00003E00007E000
-0FE0001FFFE0FFFFE0FFFFE00FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE000
-0FE0000FE0000FE0000FE0000FE0000FE0700FE0700FE0700FE0700FE0700FE0700FE070
-07F0E003F0C001FF80007F0014267FA51A> I<FFE07FF0FFE07FF0FFE07FF00FE007F00F
-E007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00F
-E007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE00FF00F
-E00FF007E017F003F067FF01FFC7FF007F87FF201B7D9A25> I E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fm cmr12 14.4 20
-/Fm 20 118 df<78FCFCFEFE7A02020202040404080810204007127B8510> 44
-D<00200000E00001E0000FE000FFE000F1E00001E00001E00001E00001E00001E00001E0
-0001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E0
-0001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E0
-0001E00003F000FFFFC0FFFFC012287BA71D> 49 D<01FC0007FF000C0FC01803E02001
-F06001F04000F84000F8F800FCFC00FCFC007CFC007CFC007C7800FC0000FC0000F80000
-F80001F00001F00003E00003C0000780000700000E00001C0000380000300000600000C0
-000180000300040200040400080800081000082000183FFFF87FFFF0FFFFF0FFFFF01628
-7DA71D> I<000FC0003FF000F01801C01803803C07007C0F007C0E00381E00003C00003C
-00003C0000780000780000780000F83F00F8C1C0F900E0FA0070FA0038FC003CFC001EFC
-001EF8001EF8001FF8001FF8001FF8001F78001F78001F78001F78001F3C001E3C001E1C
-003C1E003C0E007807007003C1E001FFC0007E0018297EA71D> 54
-D<007E0001FF800781C00F00E01E00703C00383C003878003C78003CF8001EF8001EF800
-1EF8001EF8001FF8001FF8001FF8001F78001F78003F78003F3C003F1C005F0E005F0700
-9F03831F00FC1F00001E00001E00001E00003E00003C00003C0000381C00783E00703E00
-E03C01C01803801C0F000FFE0003F80018297EA71D> 57 D<0000FF00100007FFE03000
-1FC07830003E000C7000F80006F001F00003F003E00001F007C00000F00F800000700F80
-0000701F000000303F000000303E000000303E000000107E000000107E000000107C0000
-0000FC00000000FC00000000FC00000000FC00000000FC00000000FC00000000FC000000
-00FC00000000FC0000FFFF7C0000FFFF7E000003F07E000001F03E000001F03E000001F0
-3F000001F01F000001F00F800001F00F800001F007C00001F003E00001F001F00002F000
-F80002F0003E000C70001FC038300007FFE0100000FF8000282B7DA92E> 71
-D<01FFFE01FFFE0007E00003E00003E00003E00003E00003E00003E00003E00003E00003
-E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003
-E00003E00003E00003E00003E00003E00003E00003E03003E07803E0FC03E0FC03E0FC03
-C0F807C0400780200F00300E000C3C0003F000172A7DA81E> 74
-D<0001FF0000000F01E000003C0078000078003C0000E0000E0001E0000F0003C0000780
-07800003C00F800003E01F000001F01F000001F03E000000F83E000000F87E000000FC7E
-000000FC7C0000007C7C0000007CFC0000007EFC0000007EFC0000007EFC0000007EFC00
-00007EFC0000007EFC0000007EFC0000007EFC0000007E7C0000007C7E000000FC7E0000
-00FC7E000000FC3E000000F83F000001F81F000001F01F000001F00F800003E007800003
-C007C00007C003E0000F8000F0001E000078003C00003C007800000F01E0000001FF0000
-272B7DA92E> 79 D<03FC00000C070000100380003C01C0003E01E0003E00F0001C00F0
-000800F0000000F0000000F0000000F000007FF00003E0F0000F80F0001E00F0003C00F0
-007C00F0007800F040F800F040F800F040F800F040F801F0407C01F0403C0278801E0C7F
-8007F01E001A1A7E991D> 97 D<0F000000FF000000FF0000001F0000000F0000000F00
-00000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F00
-00000F0000000F07E0000F1838000F600E000F8007000F8007800F0003C00F0003C00F00
-01E00F0001E00F0001F00F0001F00F0001F00F0001F00F0001F00F0001F00F0001F00F00
-01E00F0001E00F0003E00F0003C00F0003800F8007800E800F000E401C000C303800080F
-C0001C2A7EA921> I<007F0001C0E00700100E00781E00F83C00F83C00707C0020780000
-F80000F80000F80000F80000F80000F80000F80000F800007800007C00003C00083C0008
-1E00100E002007006001C180007E00151A7E991A> I<00FC000387800701C00E01E01C00
-E03C00F03C00F0780078780078F80078F80078FFFFF8F80000F80000F80000F80000F800
-007800007800003C00083C00081E00100E002007004001C180007E00151A7E991A> 101
-D<00000F0001FC3080070743800E03C3801E03C1003C01E0003C01E0007C01F0007C01F0
-007C01F0007C01F0007C01F0003C01E0003C01E0001E03C0000E0380001707000011FC00
-0030000000300000003000000030000000180000001FFF80000FFFF00007FFF80018007C
-0030001E0070000E0060000700E0000700E0000700E0000700E000070070000E0070000E
-0038001C001C0038000781E00000FF000019287E9A1D> 103 D<1E003F003F003F003F00
-1E000000000000000000000000000000000000000F00FF00FF001F000F000F000F000F00
-0F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F00FFF0FFF0
-0C297EA811> 105 D<007E0003C3C00700E00E00701C00383C003C3C003C78001E78001E
-F8001FF8001FF8001FF8001FF8001FF8001FF8001FF8001F78001E78001E3C003C3C003C
-1C00380E00700700E003C3C0007E00181A7E991D> 111 D<003F010001E0830003804300
-0F0027001E0017001E001F003C000F007C000F007C000F0078000F00F8000F00F8000F00
-F8000F00F8000F00F8000F00F8000F00F8000F007C000F007C000F003C000F003E001F00
-1E001F000F002F0007804F0001C18F00007E0F0000000F0000000F0000000F0000000F00
-00000F0000000F0000000F0000000F0000000F0000000F000000FFF00000FFF01C267E99
-1F> 113 D<0F0F80FF11C0FF23E01F43E00F83E00F81C00F80000F00000F00000F00000F
-00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F
-00000F8000FFFC00FFFC00131A7E9917> I<07F0801C0D80300380600180E00180E00080
-E00080F00080F800007E00007FE0003FFC001FFE0007FF00003F800007808003C08003C0
-8001C0C001C0C001C0E00180E00380F00300CC0E0083F800121A7E9917> I<0080000080
-000080000080000180000180000180000380000380000780000F80001FFF80FFFF800780
-000780000780000780000780000780000780000780000780000780000780000780000780
-0007804007804007804007804007804007804007804003C08001C08000E100003E001225
-7FA417> I<0F000F00FF00FF00FF00FF001F001F000F000F000F000F000F000F000F000F
-000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F
-000F000F000F000F000F000F000F001F000F001F0007002F0003804F8001C08FF0007F0F
-F01C1A7E9921> I E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fn cmr17 20.74 18
-/Fn 18 119 df<000001FF00008000001FFFE0018000007F007801800001F8000E038000
-03E000070780000FC000018780001F000000CF80003E0000006F80007C0000003F8000F8
-0000003F8001F00000001F8003F00000000F8007E00000000F8007C000000007800FC000
-000007800FC000000007801F8000000003801F8000000003803F8000000003803F000000
-0001803F0000000001807F0000000001807F0000000001807E0000000000007E00000000
-0000FE000000000000FE000000000000FE000000000000FE000000000000FE0000000000
-00FE000000000000FE000000000000FE000000000000FE000000000000FE000000000000
-FE0000000000007E0000000000007E0000000000007F0000000000007F0000000001803F
-0000000001803F0000000001803F8000000001801F8000000001801F8000000003000FC0
-00000003000FC0000000030007E0000000060007E0000000060003F0000000060001F000
-00000C0000F80000001800007C0000001800003E0000003000001F0000006000000FC000
-01C0000003E0000380000001F8000E000000007F007C000000001FFFF00000000001FF00
-0000313D7CBB39> 67 D<FFFFFC000000FFFFFC00000003FE0000000001F80000000001
-F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001
-F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001
-F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001
-F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001
-F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001
-F80000000001F80000000001F80000000001F80000006001F80000006001F80000006001
-F80000006001F80000006001F8000000E001F8000000C001F8000000C001F8000000C001
-F8000000C001F8000001C001F8000001C001F8000001C001F8000003C001F8000007C001
-F8000007C001F800000FC001F800003F8001F80000FF8003FC0007FF80FFFFFFFFFF80FF
-FFFFFFFF802B3B7CBA32> 76 D<000003FF00000000001E01E000000000F0003C000000
-03C0000F000000078000078000000F000003C000003E000001F000007C000000F80000F8
-0000007C0001F00000003E0001F00000003E0003E00000001F0007E00000001F8007C000
-00000F800FC00000000FC00F8000000007C01F8000000007E01F8000000007E03F000000
-0003F03F0000000003F03F0000000003F07F0000000003F87E0000000001F87E00000000
-01F87E0000000001F8FE0000000001FCFE0000000001FCFE0000000001FCFE0000000001
-FCFE0000000001FCFE0000000001FCFE0000000001FCFE0000000001FCFE0000000001FC
-FE0000000001FCFE0000000001FC7E0000000001F87F0000000003F87F0000000003F87F
-0000000003F87F0000000003F83F0000000003F03F8000000007F01F8000000007E01F80
-00000007E01FC00000000FE00FC00000000FC007C00000000F8007E00000001F8003E000
-00001F0001F00000003E0001F80000007E0000F80000007C00007C000000F800003E0000
-01F000000F000003C000000780000780000003E0001F00000000F8007C000000001E01E0
-0000000003FF000000363D7CBB3E> 79 D<003F80000001C0F0000003003C000004001E
-00000C000F000018000780001C0007C0003E0003C0003F0003E0003F0003E0003F0003E0
-001E0003E000000003E000000003E000000003E00000003FE000000FF3E000007E03E000
-01F803E00003E003E0000FC003E0001F8003E0003F0003E0003E0003E0007E0003E0007E
-0003E060FC0003E060FC0003E060FC0003E060FC0007E060FC0007E0607C000BE0607E00
-0BE0603E0011F0C01F0060F0C007C1807F8000FE003E0023257CA427> 97
-D<03E0000000FFE0000000FFE000000007E000000003E000000003E000000003E0000000
-03E000000003E000000003E000000003E000000003E000000003E000000003E000000003
-E000000003E000000003E000000003E000000003E000000003E000000003E000000003E0
-00000003E000000003E03FC00003E0E0780003E3001C0003E6000F0003E800078003F800
-03C003F00001E003E00001F003E00000F003E00000F803E00000F803E00000FC03E00000
-7C03E000007C03E000007E03E000007E03E000007E03E000007E03E000007E03E000007E
-03E000007E03E000007E03E000007E03E000007C03E000007C03E00000FC03E00000F803
-E00000F803E00001F003E00001E003F00003E003D80003C003C80007800384000E000383
-001C000381C0F00003003F8000273C7EBB2C> I<0007F800003C0E0000F0018001E000C0
-03C00060078000300F0000701F0000F81F0001F83E0001F83E0001F87E0000F07C000000
-7C000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000
-FC0000007C0000007C0000007E0000003E0000003E00000C1F00000C1F0000180F800018
-0780003003C0006001E000C000F00180003C0E000007F8001E257DA423> I<0007F80000
-3C1E0000F0078001C003C003C001E0078000F00F0000F81F0000781E00007C3E00007C3E
-00007C7E00003E7C00003E7C00003EFC00003EFC00003EFFFFFFFEFC000000FC000000FC
-000000FC000000FC000000FC0000007C0000007C0000007E0000003E0000003E0000061F
-0000060F00000C0F80000C0780001803C0003000E00060007000C0001E07000003FC001F
-257EA423> 101 D<0000FC0000078300000E0380001C07C0003C0FC000780FC000F80FC0
-00F8078000F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
-01F0000001F0000001F0000001F0000001F0000001F0000001F00000FFFFFC00FFFFFC00
-01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
-01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
-01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
-01F0000001F0000001F0000001F0000001F0000003F800007FFFE0007FFFE0001A3C7FBB
-18> I<07000F801FC01FC01FC00F80070000000000000000000000000000000000000000
-0000000000000007C0FFC0FFC00FC007C007C007C007C007C007C007C007C007C007C007
-C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007
-C007C00FE0FFFEFFFE0F397DB815> 105 D<0003800007C0000FE0000FE0000FE00007C0
-000380000000000000000000000000000000000000000000000000000000000000000000
-0000000000000007E000FFE000FFE0000FE00003E00003E00003E00003E00003E00003E0
-0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0
-0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0
-0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0
-7803C0FC07C0FC0780FC0780FC0F00780E00381C000FE000134A82B818> I<07C0FFC0FF
-C00FC007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007
-C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007
-C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007
-C00FE0FFFEFFFE0F3C7DBB15> 108 D<03E01FE0003FC000FFE0607C00C0F800FFE0801E
-01003C0007E3000F06001E0003E4000F88001F0003E4000F88001F0003E8000790000F00
-03E80007D0000F8003F00007E0000F8003F00007E0000F8003E00007C0000F8003E00007
-C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F80
-03E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007
-C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F80
-03E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007
-C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F80
-07F0000FE0001FC0FFFF81FFFF03FFFEFFFF81FFFF03FFFE3F257EA443> I<03E01FE000
-FFE0607C00FFE0801E0007E3000F0003E4000F8003E4000F8003E800078003E80007C003
-F00007C003F00007C003E00007C003E00007C003E00007C003E00007C003E00007C003E0
-0007C003E00007C003E00007C003E00007C003E00007C003E00007C003E00007C003E000
-07C003E00007C003E00007C003E00007C003E00007C003E00007C003E00007C003E00007
-C003E00007C003E00007C003E00007C003E00007C007F0000FE0FFFF81FFFFFFFF81FFFF
-28257EA42C> I<0007FC0000001C070000007001C00001E000F00003C00078000780003C
-000F00001E001F00001F001E00000F003E00000F803E00000F807C000007C07C000007C0
-7C000007C0FC000007E0FC000007E0FC000007E0FC000007E0FC000007E0FC000007E0FC
-000007E0FC000007E0FC000007E07C000007C07C000007C07E00000FC03E00000F803E00
-000F801E00000F001F00001F000F00001E000780003C0003C000780001E000F000007001
-C000001C0700000007FC000023257EA427> I<03E03E00FFE0C300FFE1078007E20FC003
-E40FC003E80FC003E8078003E8030003F0000003F0000003F0000003E0000003E0000003
-E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003
-E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003
-E0000003E0000003E0000007F00000FFFFC000FFFFC0001A257EA41E> 114
-D<00FF02000700C6000C002E0010001E0030001E0060000E0060000E00E0000600E00006
-00E0000600F0000600F8000600FC0000007F0000003FF000003FFF80000FFFE00007FFF0
-0001FFFC00003FFE000001FE0000003F00C0001F00C0000F80C0000780E0000380E00003
-80E0000380E0000380F0000300F0000300F8000700F8000600E4000C00E2001800C18070
-00807F800019257DA41F> I<003000000030000000300000003000000030000000300000
-0070000000700000007000000070000000F0000000F0000001F0000001F0000003F00000
-07F000001FFFFE00FFFFFE0001F0000001F0000001F0000001F0000001F0000001F00000
-01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
-01F0000001F0000001F0000001F0000001F0018001F0018001F0018001F0018001F00180
-01F0018001F0018001F0018001F0018000F0010000F8030000F8030000780200003C0400
-000E08000003F00019357FB41E> I<FFFE000FFFFFFE000FFF07F00007F803E00003E003
-E00001C001F00001C001F000018001F800018000F800030000F8000300007C000600007C
-000600007E000600003E000C00003E000C00003F001C00001F001800001F001800000F80
-3000000F803000000FC070000007C060000007C060000003E0C0000003E0C0000003F1C0
-000001F180000001F180000000FB00000000FB00000000FF000000007E000000007E0000
-00003C000000003C000000003C0000000018000028257FA42A> 118
-D E
-%EndDVIPSBitmapFont
-end
-%%EndProlog
-%%BeginSetup
-%%Feature: *Resolution 300dpi
-TeXDict begin
-%%PaperSize: a4
-
-userdict/PStoPSxform PStoPSmatrix matrix currentmatrix
- matrix invertmatrix matrix concatmatrix
- matrix invertmatrix put
-%%EndSetup
-%%Page: (0,1) 1
-userdict/PStoPSsaved save put
-PStoPSmatrix setmatrix
-595.000000 0.271378 translate
-90 rotate
-0.706651 dup scale
-userdict/PStoPSmatrix matrix currentmatrix put
-userdict/PStoPSclip{0 0 moveto
- 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto
- closepath}put initclip
-/showpage{}def/copypage{}def/erasepage{}def
-PStoPSxform concat
-1 0 bop Fn 281 370 a(Cleaner) p 570 370 a(seman) n(tics) p
-927 370 a(for) p 1047 370 a(Ob) t(jectiv) n(e) p 1404
-370 a(Lab) r(el) p Fm 717 518 a(Jacques) p 934 518 a(Garrigue) 719
-634 y(Octob) r(er) p 945 634 a(26,) p 1040 634 a(1999) p
-Fl 11 836 a(Credits) p Fk 11 929 a(This) p 122 929 a(prop) q(osal) p
-319 929 a(con) o(tains) p 510 929 a(ideas) p 632 929
-a(from) p 747 929 a(Damien) p 928 929 a(Doligez) p 1101
-929 a(and) p 1196 929 a(Pierre) p 1340 929 a(W) l(eis.) p
-Fl 11 1073 a(Lab) r(els) p 221 1073 a(and) p 351 1073
-a(optionals) p Fk 11 1165 a(Lab) q(els) p 165 1165 a(and) p
-259 1165 a(optional) p 449 1165 a(argumen) o(ts) p 687
-1165 a(had) p 781 1165 a(t) o(w) o(o) p 873 1165 a(problems) p
-1082 1165 a(in) p 1139 1165 a(Ob) s(jectiv) o(e) p 1360
-1165 a(Lab) q(el.) p Fj 83 1280 a(\017) p Fk 133 1280
-a(They) p 259 1280 a(w) o(ere) p 372 1280 a(not) p 459
-1280 a(fully) p 570 1280 a(coheren) o(t) p 767 1280 a(with) p
-878 1280 a(the) p 963 1280 a(original) p 1139 1280 a(call-b) o(y-v) m
-(alue) p 1423 1280 a(seman) o(tics) p 1644 1280 a(of) p
-1700 1280 a(the) p 1784 1280 a(lan-) 133 1340 y(guage.) p
-303 1340 a(In) p 368 1340 a(some) p 495 1340 a(\(subtle\)) p
-681 1340 a(cases,) p 823 1340 a(a) p 868 1340 a(side-e\013ect) p
-1099 1340 a(migh) o(t) p 1243 1340 a(get) p 1329 1340
-a(dela) o(y) o(ed) p 1508 1340 a(more) p 1635 1340 a(than) p
-1753 1340 a(in) p 1814 1340 a(an) 133 1400 y(un) o(t) o(yp) q(ed) p
-322 1400 a(seman) o(tics.) p Fj 83 1502 a(\017) p Fk
-133 1502 a(F) l(or) p 220 1502 a(optional) p 410 1502
-a(argumen) o(ts,) p 660 1502 a(no) p 728 1502 a(un) o(t) o(yp) q(ed) p
-918 1502 a(seman) o(tics) p 1139 1502 a(existed.) 84
-1616 y(This) p 195 1616 a(new) p 295 1616 a(prop) q(osal) p
-492 1616 a(corrects) p 674 1616 a(these) p 799 1616 a(t) o(w) o(o) p
-891 1616 a(\015a) o(ws.) p Fi 11 1746 a(Syn) n(tax) p
-Fk 11 1838 a(W) l(e) p 95 1838 a(k) o(eep) p 206 1838
-a(Ob) s(jectiv) o(e) p 426 1838 a(Lab) q(el's) p 594
-1838 a(syn) o(tax,) p 764 1838 a(except) p 917 1838 a(for) p
-991 1838 a(default) p 1155 1838 a(v) m(alues) p 1301
-1838 a(in) p 1357 1838 a(optional) p 1547 1838 a(argumen) o(ts.) p
-Fh 329 1944 a(typ) n(expr) p Fk 528 1944 a(::=) p Fg
-634 1944 a(:) p 656 1944 a(:) p 678 1944 a(:) p Fj 579
-2004 a(j) p Fh 634 2004 a(typ) n(expr) p Fj 806 2004
-a(!) p Fh 870 2004 a(typ) n(expr) p Fj 579 2064 a(j) p
-Fk 634 2064 a([?]) p Fi(lab) r(el) p Fk 801 2064 a(:) p
-Fh(typ) n(expr) p Fj 987 2064 a(!) p Fh 1050 2064 a(typ) n(expr) 391
-2124 y(expr) p Fk 528 2124 a(::=) p Fg 634 2124 a(:) p
-656 2124 a(:) p 678 2124 a(:) p Fj 579 2185 a(j) p Fh
-634 2185 a(expr) p 746 2185 a(lab) n(ele) n(d-expr) p
-Ff 991 2163 a(+) p Fj 579 2245 a(j) p Fe 634 2245 a(fun) p
-Fj 728 2245 a(f) p Fh(lab) n(ele) n(d-simple-p) n(attern) p
-Fj 1209 2245 a(g) p Ff 1234 2227 a(+) p Fk 1280 2245
-a([) p Fe(when) p Fh 1412 2245 a(expr) p Fk 1507 2245
-a(]) p Fj 1535 2245 a(!) p Fh 1599 2245 a(expr) p Fj
-579 2305 a(j) p Fe 634 2305 a(function) p Fh 856 2305
-a(lab) n(ele) n(d-p) n(attern) p Fk 1177 2305 a([) p
-Fe(when) p Fh 1309 2305 a(expr) p Fk 1404 2305 a(]) p
-Fj 1432 2305 a(!) p Fh 1496 2305 a(expr) p Fj 785 2365
-a(f) p Fe(|) p Fh 851 2365 a(lab) n(ele) n(d-p) n(attern) p
-Fk 1172 2365 a([) p Fe(when) p Fg 1305 2365 a(expr) p
-Fk 1403 2365 a(]) p Fj 1430 2365 a(!) p Fh 1494 2365
-a(expr) p Fj 1589 2365 a(g) p Fd 1614 2347 a(\003) p
-Fh 242 2425 a(lab) n(ele) n(d-expr) p Fk 528 2425 a(::=) p
-634 2425 a([?]) p Fh(expr) p Fj 579 2486 a(j) p Fk 634
-2486 a([?]) p Fi(lab) r(el) p Fk 801 2486 a(:) p Fh(expr) 182
-2546 y(lab) n(ele) n(d-p) n(attern) p Fk 528 2546 a(::=) p
-Fh 634 2546 a(p) n(attern) p Fj 579 2606 a(j) p Fi 634
-2606 a(lab) r(el) p Fk 751 2606 a(:) p Fh(p) n(attern) p
-Fj 579 2666 a(j) p Fk 634 2666 a(?[) p Fe(\() p Fh(expr) p
-Fe(\)) p Fk(]) p Fi(lab) r(el) p Fk 943 2666 a(:) p Fh
-956 2666 a(p) n(attern) p Fk 926 2937 a(1) p eop
-PStoPSsaved restore
-userdict/PStoPSsaved save put
-PStoPSmatrix setmatrix
-595.000000 421.271378 translate
-90 rotate
-0.706651 dup scale
-userdict/PStoPSmatrix matrix currentmatrix put
-userdict/PStoPSclip{0 0 moveto
- 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto
- closepath}put initclip
-PStoPSxform concat
-2 1 bop Fi 11 168 a(Dynamic) p 247 168 a(seman) n(tics) p
-Fj 11 261 a(;) p Fk 52 261 a(is) p 101 261 a(a) p 141
-261 a(notation) p 337 261 a(for) p 411 261 a(the) p 495
-261 a(empt) o(y) p 644 261 a(lab) q(el.) 86 366 y(\() p
-Fe(fun) p Fi 198 366 a(l) p Fc 214 373 a(i) p Fk 227
-366 a(:) p Fg(x) p Fj 282 366 a(!) p Fg 346 366 a(e) p
-Fk(\)) p Fi 404 366 a(l) p Fc 420 373 a(1) p Fk 442 366
-a(:) p Fg 455 366 a(e) p Ff 478 373 a(1) p Fg 506 366
-a(:) p 528 366 a(:) p 550 366 a(:) p Fi 571 366 a(l) p
-Fc 587 373 a(n) p Fk 612 366 a(:) p Fg 625 366 a(e) p
-Fb 648 373 a(n) p Fj 515 427 a(!) p Fk 579 427 a(\() p
-Fg(e) p Fk([) p Fg(e) p Fb 658 434 a(i) p Fg 671 427
-a(=x) p Fk(]) p Fi 752 427 a(l) p Fc 768 434 a(1) p Fk
-790 427 a(:) p Fg(e) p Ff 827 434 a(1) p Fg 855 427 a(:) p
-877 427 a(:) p 899 427 a(:) p Fi 920 427 a(l) p Fc 936
-434 a(i) p Fd(\000) p Fc(1) p Fk 997 427 a(:) p Fg 1010
-427 a(e) p Fb 1033 434 a(i) p Fd(\000) p Ff(1) p Fi 1108
-427 a(l) p Fc 1124 434 a(i) p Ff(+) p Fc(1) p Fk 1185
-427 a(:) p Fg(e) p Fb 1222 434 a(i) p Ff(+1) p Fg 1289
-427 a(:) p 1311 427 a(:) p 1333 427 a(:) p Fi 1354 427
-a(l) p Fc 1370 434 a(n) p Fk 1395 427 a(:) p Fg 1408
-427 a(e) p Fb 1431 434 a(n) p Fk 86 487 a(\() p Fe(fun) p
-Fk 198 487 a(?) p Fi(l) p Fc 237 494 a(i) p Fk 250 487
-a(:) p Fg(x) p Fj 305 487 a(!) p Fg 369 487 a(e) p Fk(\)) p
-Fi 427 487 a(l) p Fc 443 494 a(1) p Fk 465 487 a(:) p
-Fg 478 487 a(e) p Ff 501 494 a(1) p Fg 529 487 a(:) p
-551 487 a(:) p 573 487 a(:) p Fi 594 487 a(l) p Fc 610
-494 a(n) p Fk 635 487 a(:) p Fg 648 487 a(e) p Fb 671
-494 a(n) p Fj 515 547 a(!) p Fg 579 547 a(e) p Fk([) p
-Fe(Some) p Fk 717 547 a(\() p Fg(e) p Fb 759 554 a(i) p
-Fk 773 547 a(\)) p Fg(=x) p Fk(]) p Fi 874 547 a(l) p
-Fc 890 554 a(1) p Fk 912 547 a(:) p Fg 925 547 a(e) p
-Ff 948 554 a(1) p Fg 976 547 a(:) p 998 547 a(:) p 1020
-547 a(:) p Fi 1042 547 a(l) p Fc 1058 554 a(i) p Fd(\000) p
-Fc(1) p Fk 1118 547 a(:) p Fg(e) p Fb 1155 554 a(i) p
-Fd(\000) p Ff(1) p Fi 1230 547 a(l) p Fc 1246 554 a(i) p
-Ff(+) p Fc(1) p Fk 1307 547 a(:) p Fg 1320 547 a(e) p
-Fb 1343 554 a(i) p Ff(+1) p Fg 1410 547 a(:) p 1432 547
-a(:) p 1454 547 a(:) p Fi 1476 547 a(l) p Fc 1492 554
-a(n) p Fk 1516 547 a(:) p Fg(e) p Fb 1553 554 a(n) p
-Fk 86 607 a(\() p Fe(fun) p Fk 198 607 a(?) p Fi(l) p
-Fk(:) p Fg 250 607 a(x) p Fj 292 607 a(!) p Fg 356 607
-a(e) p Fk(\)) p Fi 413 607 a(l) p Fc 429 614 a(1) p Fk
-451 607 a(:) p Fg(e) p Ff 488 614 a(1) p Fg 516 607 a(:) p
-538 607 a(:) p 560 607 a(:) p Fi 581 607 a(l) p Fc 597
-614 a(n) p Fk 621 607 a(:) p Fg(e) p Fb 658 614 a(n) p
-Fk 1154 607 a(when) p Fi 1281 607 a(l) p Fc 1297 614
-a(i) p Fk 1324 607 a(=) p Fj 1376 607 a(;) p Fk 1417
-607 a(and) p Fg 1512 607 a(l) p Fj 1541 607 a(62) p 1588
-607 a(f) p Fi(l) p Fc 1629 614 a(1) p Fg 1660 607 a(:) p
-1682 607 a(:) p 1704 607 a(:) p Fi 1725 607 a(l) p Fc
-1741 614 a(n) p Fj 1765 607 a(g) 515 667 y(!) p Fg 579
-667 a(e) p Fk([) p Fe(None) p Fg 717 667 a(=x) p Fk(]) p
-Fi 799 667 a(l) p Fc 815 674 a(1) p Fk 837 667 a(:) p
-Fg(e) p Ff 874 674 a(1) p Fg 901 667 a(:) p 923 667 a(:) p
-945 667 a(:) p Fi 967 667 a(l) p Fc 983 674 a(n) p Fk
-1007 667 a(:) p Fg(e) p Fb 1044 674 a(n) p Fk 86 728
-a(\(\() p Fe(fun) p Fi 217 728 a(l) p Fk(:) p Fg 246
-728 a(x) p Fj 288 728 a(!) p Fg 352 728 a(e) p Fk(\)) p
-Fi 409 728 a(l) p Fc 425 735 a(1) p Fk 447 728 a(:) p
-Fg(e) p Ff 484 735 a(1) p Fg 511 728 a(:) p 533 728 a(:) p
-555 728 a(:) p Fi 577 728 a(l) p Fc 593 735 a(m) p Fk
-629 728 a(:) p Fg 642 728 a(e) p Fb 665 735 a(m) p Fk
-698 728 a(\)) p Fi 733 728 a(l) p Fc 749 735 a(m) p Ff(+) p
-Fc(1) p Fk 833 728 a(:) p Fg 846 728 a(e) p Fb 869 735
-a(m) p Ff(+1) p Fg 955 728 a(:) p 977 728 a(:) p 999
-728 a(:) p Fi 1021 728 a(l) p Fc 1037 735 a(n) p Fk 1061
-728 a(:) p Fg(e) p Fb 1098 735 a(n) p Fk 1373 728 a(when) p
-Fi 1501 728 a(l) p Fj 1530 728 a(62) p 1577 728 a(f) p
-Fi(l) p Fc 1618 735 a(1) p Fg 1648 728 a(:) p 1670 728
-a(:) p 1692 728 a(:) p Fi 1714 728 a(l) p Fc 1730 735
-a(m) p Fj 1765 728 a(g) 515 788 y(!) p Fk 579 788 a(\() p
-Fe(fun) p Fi 691 788 a(l) p Fk(:) p Fg 720 788 a(x) p
-Fj 761 788 a(!) p Fg 825 788 a(e) p Fk(\)) p Fi 883 788
-a(l) p Fc 899 795 a(1) p Fk 921 788 a(:) p Fg 934 788
-a(e) p Ff 957 795 a(1) p Fg 985 788 a(:) p 1007 788 a(:) p
-1029 788 a(:) p Fi 1051 788 a(l) p Fc 1067 795 a(n) p
-Fk 1091 788 a(:) p Fg 1104 788 a(e) p Fb 1127 795 a(n) p
-Fk 86 848 a(\(\() p Fe(fun) p Fk 217 848 a(?) p Fi(l) p
-Fk(:) p Fg 269 848 a(x) p Fj 311 848 a(!) p Fg 375 848
-a(e) p Fk(\)) p Fi 432 848 a(l) p Fc 448 855 a(1) p Fk
-470 848 a(:) p Fg(e) p Ff 507 855 a(1) p Fg 535 848 a(:) p
-557 848 a(:) p 579 848 a(:) p Fi 600 848 a(l) p Fc 616
-855 a(m) p Fk 652 848 a(:) p Fg 665 848 a(e) p Fb 688
-855 a(m) p Fk 721 848 a(\)) p Fi 756 848 a(l) p Fc 772
-855 a(m) p Ff(+) p Fc(1) p Fk 856 848 a(:) p Fg 869 848
-a(e) p Fb 892 855 a(m) p Ff(+1) p Fg 978 848 a(:) p 1000
-848 a(:) p 1022 848 a(:) p Fi 1044 848 a(l) p Fc 1060
-855 a(n) p Fk 1084 848 a(:) p Fg(e) p Fb 1121 855 a(n) p
-Fk 1261 848 a(when) p Fj 1388 848 a(f) p Fi(l) p Fg(;) p
-Fj 1451 848 a(;g) p 1530 848 a(6) m(\\) p 1577 848 a(f) p
-Fi(l) p Fc 1618 855 a(1) p Fg 1648 848 a(:) p 1670 848
-a(:) p 1692 848 a(:) p Fi 1714 848 a(l) p Fc 1730 855
-a(m) p Fj 1765 848 a(g) 515 908 y(!) p Fk 579 908 a(\() p
-Fe(fun) p Fk 691 908 a(?) p Fi(l) p Fk(:) p Fg 743 908
-a(x) p Fj 785 908 a(!) p Fg 848 908 a(e) p Fk(\)) p Fi
-906 908 a(l) p Fc 922 915 a(1) p Fk 944 908 a(:) p Fg(e) p
-Ff 981 915 a(1) p Fg 1008 908 a(:) p 1030 908 a(:) p
-1052 908 a(:) p Fi 1074 908 a(l) p Fc 1090 915 a(n) p
-Fk 1114 908 a(:) p Fg 1127 908 a(e) p Fb 1150 915 a(n) p
-Fi 11 1035 a(T) n(yping) p Fk 11 1127 a(Seman) o(tics) p
-240 1127 a(are) p 321 1127 a(k) o(ept) p 430 1127 a(throughout) p
-685 1127 a(compilation) p 950 1127 a(b) o(y) p 1018 1127
-a(disallo) o(wing) p 1269 1127 a(lab) q(el) p 1387 1127
-a(comm) o(utation) p 1684 1127 a(for) p 1759 1127 a(func-) 11
-1187 y(tion) p 116 1187 a(t) o(yp) q(es.) p 278 1187
-a(Ho) o(w) o(ev) o(er,) p 494 1187 a(the) p 583 1187
-a(original) p 764 1187 a(comfort) p 949 1187 a(of) p
-1009 1187 a(out-of-order) p 1283 1187 a(application) p
-1540 1187 a(is) p 1594 1187 a(reco) o(v) o(ered) p 1814
-1187 a(b) o(y) 11 1247 y(allo) o(wing) p 207 1247 a(argumen) o(t) p
-431 1247 a(reordering) p 670 1247 a(in) p 732 1247 a(application,) p
-1005 1247 a(when) p 1138 1247 a(the) p 1227 1247 a(function's) p
-1457 1247 a(t) o(yp) q(e) p 1572 1247 a(is) p Fh 1626
-1247 a(wel) r(l) p 1731 1247 a(known) p Fk 11 1308 a(\() p
-Fh(c.f.) p Fk 118 1308 a(p) q(olymorphic) p 400 1308
-a(metho) q(ds\).) p Fl 11 1452 a(V) p 56 1452 a(arian) n(ts) p
-Fk 11 1544 a(V) l(arian) o(t) p 187 1544 a(t) o(yping,) p
-355 1544 a(as) p 417 1544 a(it) p 468 1544 a(is) p 519
-1544 a(presen) o(ted) p 739 1544 a(in) p 798 1544 a(the) p
-884 1544 a(user's) p 1022 1544 a(man) o(ual,) p 1210
-1544 a(is) p 1261 1544 a(not) p 1350 1544 a(principal:) p
-1576 1544 a(in) p 1635 1544 a(some) p 1760 1544 a(cases) 11
-1605 y(t) o(ypabilit) o(y) p 239 1605 a(of) p 301 1605
-a(an) p 375 1605 a(expression) p 616 1605 a(ma) o(y) p
-728 1605 a(dep) q(end) p 904 1605 a(on) p 978 1605 a(the) p
-1069 1605 a(order) p 1202 1605 a(in) p 1265 1605 a(whic) o(h) p
-1411 1605 a(the) p 1502 1605 a(t) o(yping) p 1660 1605
-a(algorithm) 11 1665 y(pro) q(ceeds.) p Fe 133 1779 a(#) p
-184 1779 a(let) p 286 1779 a(f1) p 363 1779 a(\(x) p
-440 1779 a(:) p 491 1779 a([<) p 568 1779 a(a) p 620
-1779 a(b\(int\)]\)) p 850 1779 a(=) p 902 1779 a(\(\)) 184
-1839 y(let) p 286 1839 a(f2) p 363 1839 a(\(x) p 440
-1839 a(:) p 491 1839 a([<) p 568 1839 a(a]\)) p 671 1839
-a(=) p 722 1839 a(\(\)) 184 1899 y(let) p 286 1899 a(f3) p
-363 1899 a(\(x) p 440 1899 a(:) p 491 1899 a([<) p 568
-1899 a(a) p 620 1899 a(b\(bool\)]\)) p 876 1899 a(=) p
-927 1899 a(\(\);;) 133 1960 y(val) p 235 1960 a(f1) p
-312 1960 a(:) p 363 1960 a([<) p 440 1960 a(a) p 491
-1960 a(b\(int\)]) p 696 1960 a(->) p 773 1960 a(unit) p
-902 1960 a(=) p 953 1960 a(<fun>) 133 2020 y(val) p 235
-2020 a(f2) p 312 2020 a(:) p 363 2020 a([<) p 440 2020
-a(a]) p 517 2020 a(->) p 594 2020 a(unit) p 722 2020
-a(=) p 773 2020 a(<fun>) 133 2080 y(val) p 235 2080 a(f3) p
-312 2080 a(:) p 363 2080 a([<) p 440 2080 a(a) p 491
-2080 a(b\(bool\)]) p 722 2080 a(->) p 799 2080 a(unit) p
-927 2080 a(=) p 978 2080 a(<fun>) 133 2140 y(#) p 184
-2140 a(fun) p 286 2140 a(x) p 338 2140 a(->) p 414 2140
-a(f1) p 491 2140 a(x;) p 568 2140 a(f2) p 645 2140 a(x;) p
-722 2140 a(f3) p 799 2140 a(x;;) 133 2200 y(-) p 184
-2200 a(:) p 235 2200 a([<) p 312 2200 a(a]) p 389 2200
-a(->) p 466 2200 a(unit) p 594 2200 a(=) p 645 2200 a(<fun>) 133
-2260 y(#) p 184 2260 a(fun) p 286 2260 a(x) p 338 2260
-a(->) p 414 2260 a(f1) p 491 2260 a(x;) p 568 2260 a(f3) p
-645 2260 a(x;;) 133 2321 y(Character) o(s) p 414 2321
-a(18-19:) 133 2381 y(This) p 261 2381 a(expressio) o(n) p
-543 2381 a(has) p 645 2381 a(type) p 773 2381 a([<) p
-850 2381 a(a) p 902 2381 a(b\(int\)]) p 1107 2381 a(but) p
-1209 2381 a(is) p 1286 2381 a(here) p 1414 2381 a(used) p
-1542 2381 a(with) p 1670 2381 a(type) 184 2441 y([<) p
-261 2441 a(a) p 312 2441 a(b\(bool\)]) p Fk 84 2555 a(Here) p
-204 2555 a(the) p 292 2555 a(constrain) o(t) p 526 2555
-a(in) o(tro) q(duced) p 775 2555 a(b) o(y) p Fe 848 2555
-a(f2) p Fk 920 2555 a(hides) p 1049 2555 a(the) p 1138
-2555 a(constructor) p Fe 1401 2555 a(b) p Fk(,) p 1462
-2555 a(and) p 1562 2555 a(a) o(v) o(oids) p 1714 2555
-a(a) p 1760 2555 a(clash) 11 2615 y(b) q(et) o(w) o(een) p
-Fe 199 2615 a(int) p Fk 292 2615 a(and) p Fe 387 2615
-a(bool) p Fk(.) 84 2676 y(An) p 163 2676 a(easy) p 270
-2676 a(w) o(a) o(y) p 369 2676 a(to) p 428 2676 a(solv) o(e) p
-547 2676 a(this) p 642 2676 a(w) o(ould) p 784 2676 a(b) q(e) p
-850 2676 a(to) p 909 2676 a(restrict) p 1077 2676 a(hiding) p
-1226 2676 a(absen) o(t) p 1379 2676 a(lab) q(els) p 1515
-2676 a(to) p 1575 2676 a(generic) p 1739 2676 a(t) o(yp) q(es.) 11
-2736 y(This) p 124 2736 a(w) o(a) o(y) p 224 2736 a(the) p
-310 2736 a(second) p 469 2736 a(case) p 574 2736 a(w) o(ould) p
-718 2736 a(still) p 814 2736 a(fail,) p 913 2736 a(since) p
-Fe 1034 2736 a(x) p Fk 1077 2736 a(has) p 1166 2736 a(a) p
-1208 2736 a(monorphic) p 1451 2736 a(t) o(yp) q(e.) p
-1584 2736 a(This) p 1697 2736 a(solution) 11 2796 y(w) o(ould) p
-153 2796 a(b) q(e) p 219 2796 a(correct) p 382 2796 a(and) p
-477 2796 a(principal.) 926 2937 y(2) p eop
-PStoPSsaved restore
-%%Page: (2,3) 2
-userdict/PStoPSsaved save put
-PStoPSmatrix setmatrix
-595.000000 0.271378 translate
-90 rotate
-0.706651 dup scale
-userdict/PStoPSmatrix matrix currentmatrix put
-userdict/PStoPSclip{0 0 moveto
- 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto
- closepath}put initclip
-/showpage{}def/copypage{}def/erasepage{}def
-PStoPSxform concat
-3 2 bop Fk 84 168 a(Ho) o(w) o(ev) o(er,) p 293 168 a(one) p
-382 168 a(can) p 472 168 a(easily) p 606 168 a(see) p
-684 168 a(that) p 789 168 a(this) p 884 168 a(solution) p
-1068 168 a(is) p 1117 168 a(coun) o(ter-in) o(tuitiv) o(e.) p
-1504 168 a(F) l(or) p 1591 168 a(the) p 1675 168 a(user,) p
-Fe 1791 168 a(b) p Fk 1833 168 a(is) 11 229 y(already) p
-183 229 a(an) p 250 229 a(imp) q(ossible) p 488 229 a(constructor,) p
-759 229 a(and) p 854 229 a(ha) o(ving) p 1011 229 a(a) p
-1052 229 a(clash) p 1174 229 a(on) p 1242 229 a(it) p
-1291 229 a(is) p 1340 229 a(hard) p 1453 229 a(to) p
-1513 229 a(understand.) 84 289 y(Another) p 277 289 a(solution) p
-463 289 a(is) p 514 289 a(to) p 575 289 a(go) p 642 289
-a(the) p 728 289 a(opp) q(osite) p 924 289 a(w) o(a) o(y) l(.) p
-1044 289 a(T) l(o) p 1117 289 a(accept) p 1271 289 a(more) p
-1395 289 a(programs.) p 1634 289 a(This) p 1747 289 a(is) p
-1798 289 a(the) 11 349 y(w) o(a) o(y) p 109 349 a(w) o(e) p
-181 349 a(explore) p 351 349 a(here,) p 470 349 a(with) p
-581 349 a(an) p 649 349 a(unc) o(hanged) p 891 349 a(syn) o(tax.) p
-Fi 11 479 a(T) n(yping) p Fk 11 571 a(The) p 114 571
-a(idea) p 220 571 a(is) p 273 571 a(to) p 336 571 a(dela) o(y) p
-466 571 a(uni\014cation) p 711 571 a(on) p 782 571 a(constructor) p
-1043 571 a(un) o(til) p 1161 571 a(they) p 1274 571 a(are) p
-1359 571 a(explicitely) p 1595 571 a(kno) o(wn) p 1753
-571 a(to) p 1816 571 a(b) q(e) 11 631 y(presen) o(t.) p
-199 631 a(W) l(e) p 280 631 a(k) o(eep) p 390 631 a(the) p
-472 631 a(\() p Fg(T) t(;) p 546 631 a(U;) p 601 631
-a(L) p Fk(\)) p 666 631 a(represen) o(tation) p 983 631
-a(of) p 1036 631 a(v) m(arian) o(t) p 1200 631 a(t) o(yp) q(es,) p
-1341 631 a(but) p Fg 1428 631 a(T) p Fk 1478 631 a(is) p
-1525 631 a(no) p 1591 631 a(longer) p 1735 631 a(a) p
-1774 631 a(map) 11 692 y(from) p 126 692 a(constructors) p
-403 692 a(to) p 462 692 a(t) o(yp) q(es,) p 605 692 a(but) p
-694 692 a(from) p 809 692 a(constructors) p 1086 692
-a(to) p 1146 692 a(sets) p 1241 692 a(of) p 1297 692
-a(t) o(yp) q(es.) 84 752 y(When) p 230 752 a(w) o(e) p
-307 752 a(unify) p 436 752 a(t) o(w) o(o) p 532 752 a(v) m(arian) o(t) p
-702 752 a(t) o(yp) q(es,) p 850 752 a(the) p 938 752
-a(\014rst) p 1043 752 a(step) p 1150 752 a(is) p 1204
-752 a(just) p 1305 752 a(to) p 1369 752 a(tak) o(e) p
-1479 752 a(the) p 1567 752 a(union) p 1707 752 a(of) p
-1767 752 a(b) q(oth) 11 812 y(t) o(yping) p 162 812 a(en) o(vironmen) o
-(ts,) p 476 812 a(dropping) p 682 812 a(unnecessary) p
-952 812 a(t) o(yp) q(es.) 204 932 y(\() p Fg(T) p Ff
-252 939 a(1) p Fg 272 932 a(;) p 294 932 a(U) p Ff 327
-939 a(1) p Fg 346 932 a(;) p 368 932 a(L) p Ff 401 939
-a(1) p Fk 421 932 a(\)) p Fj 451 932 a(^) p Fk 495 932
-a(\() p Fg(T) p Ff 543 939 a(2) p Fg 563 932 a(;) p 585
-932 a(U) p Ff 618 939 a(2) p Fg 637 932 a(;) p 659 932
-a(L) p Ff 692 939 a(2) p Fk 712 932 a(\)) p 745 932 a(=) p
-797 932 a(\(\() p Fg(T) p Ff 864 939 a(1) p Fj 883 932
-a(j) p Fb 897 939 a(U) p Fa 921 944 a(1) p Fd 938 939
-a(\\) p Fb(U) p Fa 986 944 a(2) p Fk 1005 932 a(\)) p
-Fj 1035 932 a([) p Fk 1079 932 a(\() p Fg(T) p Ff 1127
-939 a(2) p Fj 1146 932 a(j) p Fb 1160 939 a(U) p Fa 1184
-944 a(1) p Fd 1201 939 a(\\) p Fb(U) p Fa 1249 944 a(2) p
-Fk 1268 932 a(\)) p Fg(;) p 1309 932 a(U) p Ff 1342 939
-a(1) p Fj 1373 932 a(\\) p Fg 1417 932 a(U) p Ff 1450
-939 a(2) p Fg 1470 932 a(;) p 1492 932 a(L) p Ff 1525
-939 a(1) p Fj 1556 932 a([) p Fg 1600 932 a(L) p Ff 1633
-939 a(2) p Fk 1653 932 a(\)) 84 1042 y(Here) p 203 1042
-a(the) p 291 1042 a(union) p 431 1042 a(of) p 490 1042
-a(t) o(w) o(o) p 587 1042 a(t) o(yping) p 742 1042 a(en) o(vironmen) o
-(ts) p 1046 1042 a(is) p 1099 1042 a(the) p 1187 1042
-a(p) q(oin) o(t) o(wise) p 1407 1042 a(union) p 1547
-1042 a(of) p 1606 1042 a(their) p 1727 1042 a(sets) p
-1826 1042 a(of) 11 1102 y(t) o(yp) q(es) p 140 1102 a(for) p
-214 1102 a(eac) o(h) p 324 1102 a(constructor.) 84 1162
-y(This) p 195 1162 a(\014rst) p 296 1162 a(step) p 399
-1162 a(nev) o(er) p 529 1162 a(fails.) 84 1222 y(In) p
-145 1222 a(a) p 186 1222 a(second) p 343 1222 a(step,) p
-460 1222 a(structural) p 685 1222 a(constrain) o(ts) p
-934 1222 a(are) p 1015 1222 a(enforced) p 1209 1222 a(on) p
-1277 1222 a(the) p 1361 1222 a(resulting) p 1562 1222
-a(t) o(yp) q(e) p 1672 1222 a(\() p Fg(T) t(;) p 1746
-1222 a(U;) p 1801 1222 a(L) p Fk(\).) 11 1282 y(First,) p
-Fg 144 1282 a(L) p Fk 195 1282 a(should) p 351 1282 a(b) q(e) p
-418 1282 a(included) p 614 1282 a(in) p Fg 672 1282 a(U) p
-Fk 710 1282 a(.) p 749 1282 a(Then,) p 892 1282 a(for) p
-967 1282 a(all) p 1036 1282 a(constructors) p 1314 1282
-a(app) q(earing) p 1542 1282 a(in) p Fg 1600 1282 a(L) p
-Fk(,) p 1664 1282 a(the) p 1749 1282 a(set) p 1826 1282
-a(of) 11 1343 y(t) o(yp) q(es) p 136 1343 a(asso) q(ciated) p
-365 1343 a(with) p 472 1343 a(eac) o(h) p 578 1343 a(constructor) p
-833 1343 a(is) p 878 1343 a(collapsed) p 1084 1343 a(b) o(y) p
-1148 1343 a(uni\014cation.) p 1407 1343 a(This) p 1515
-1343 a(can) p 1600 1343 a(b) q(e) p 1663 1343 a(expressed) 11
-1403 y(b) o(y) p 78 1403 a(rewriting) p 287 1403 a(rules,) p
-417 1403 a(where) p Fg 558 1403 a(e) p Fk 597 1403 a(is) p
-646 1403 a(a) p 687 1403 a(m) o(ulti-equation) p 1015
-1403 a(and) p Fg 1109 1403 a(\036) p Fk 1155 1403 a(a) p
-1195 1403 a(set) p 1271 1403 a(of) p 1327 1403 a(m) o(ultiequations) 249
-1509 y(if) p Fg 294 1509 a(L) p Fj 341 1509 a(6\032) p
-Fg 393 1509 a(U) p Fk 448 1509 a(then) p 559 1509 a(\() p
-Fg(T) t(;) p 633 1509 a(U;) p 688 1509 a(L) p Fk(\)) p
-753 1509 a(=) p Fg 805 1509 a(e) p Fj 839 1509 a(^) p
-Fg 883 1509 a(\036) p Fj 926 1509 a(\000) p 956 1509
-a(!) p 1020 1509 a(?) p Fk 249 1629 a(if) p Fg 294 1629
-a(l) p Fj 323 1629 a(2) p Fg 370 1629 a(L) p Fk 420 1629
-a(and) p Fg 515 1629 a(T) p Fk 551 1629 a(\() p Fg(l) p
-Fk 586 1629 a(\)) p 617 1629 a(=) p Fj 669 1629 a(f) p
-Fg(\034) p Ff 715 1636 a(1) p Fg 735 1629 a(;) p 757
-1629 a(:) p 779 1629 a(:) p 801 1629 a(:) p 822 1629
-a(;) p 844 1629 a(\034) p Fb 865 1636 a(n) p Fj 889 1629
-a(g) p Fk 930 1629 a(then) 298 1689 y(\() p Fg(T) t(;) p
-372 1689 a(U;) p 427 1689 a(L) p Fk(\)) p 492 1689 a(=) p
-Fg 544 1689 a(e) p Fj 577 1689 a(^) p Fg 622 1689 a(\036) p
-Fj 664 1689 a(\000) p 695 1689 a(!) p Fk 759 1689 a(\() p
-Fg(T) p Fj 814 1689 a(f) p Fg(l) p Fj 867 1689 a(7!) p
-Fg 931 1689 a(\034) p Ff 952 1696 a(1) p Fj 972 1689
-a(g) p Fg(;) p 1019 1689 a(U;) p 1074 1689 a(L) p Fk(\)) p
-1139 1689 a(=) p Fg 1191 1689 a(e) p Fj 1225 1689 a(^) p
-Fg 1269 1689 a(\034) p Ff 1290 1696 a(1) p Fk 1324 1689
-a(=) p Fg 1376 1689 a(:) p 1398 1689 a(:) p 1420 1689
-a(:) p Fk 1447 1689 a(=) p Fg 1498 1689 a(\034) p Fb
-1519 1696 a(n) p Fj 1554 1689 a(^) p Fg 1598 1689 a(\036) p
-Fk 84 1796 a(Optionally) p 331 1796 a(one) p 425 1796
-a(can) p 519 1796 a(add) p 619 1796 a(rules) p 740 1796
-a(that) p 850 1796 a(remo) o(v) o(e) p 1022 1796 a(a) p
-1067 1796 a(constructor) p Fg 1329 1796 a(l) p Fk 1366
-1796 a(from) p Fg 1486 1796 a(U) p Fk 1545 1796 a(if) p
-1594 1796 a(the) p 1683 1796 a(equation) 11 1856 y(obtained) p
-211 1856 a(from) p Fg 326 1856 a(T) p Fk 362 1856 a(\() p
-Fg(l) p Fk 397 1856 a(\)) p 431 1856 a(has) p 518 1856
-a(no) p 586 1856 a(solution.) p 790 1856 a(Suc) o(h) p
-908 1856 a(rules) p 1024 1856 a(w) o(ould) p 1167 1856
-a(b) q(e) p 1233 1856 a(sound) p 1374 1856 a(and) p 1469
-1856 a(complete.) p Fi 11 1986 a(Syn) n(tax) p 198 1986
-a(of) p 262 1986 a(t) n(yp) r(es) p Fk 11 2078 a(Thanks) p
-188 2078 a(to) p 250 2078 a(the) p 336 2078 a(go) q(o) q(d) p
-458 2078 a(prop) q(erties) p 689 2078 a(of) p 747 2078
-a(these) p 874 2078 a(constrain) o(ts,) p 1139 2078 a(the) p
-1226 2078 a(surface) p 1392 2078 a(syn) o(tax) p 1551
-2078 a(of) p 1608 2078 a(t) o(yp) q(es) p 1740 2078 a(w) o(ould) 11
-2138 y(only) p 118 2138 a(ha) o(v) o(e) p 230 2138 a(to) p
-290 2138 a(b) q(e) p 356 2138 a(sligh) o(tly) p 527 2138
-a(extended.) p Fh 590 2244 a(tag-typ) n(e) p Fk 798 2244
-a(::=) p Fh 904 2244 a(ident) p Fj 849 2304 a(j) p Fh
-904 2304 a(ident) p Fe 1031 2304 a(\() p Fh(typ) n(expr-list) p
-Fe(\)) p Fh 523 2365 a(typ) n(expr-list) p Fk 798 2365
-a(::=) p Fh 904 2365 a(typ) n(expr) p Fj 849 2425 a(j) p
-Fh 904 2425 a(typ) n(expr) p Fe 1078 2425 a(&) p Fh 1120
-2425 a(typ) n(expr-list) p Fk 84 2531 a(Notice) p 234
-2531 a(that) p 336 2531 a(a) p 373 2531 a(0-ary) p 496
-2531 a(constructor) p 751 2531 a(and) p 842 2531 a(an) p
-907 2531 a(1-ary) p 1030 2531 a(construtor) p 1262 2531
-a(are) p 1340 2531 a(con) o(tradictory) l(,) p 1648 2531
-a(and) p 1740 2531 a(w) o(ould) 11 2592 y(result) p 146
-2592 a(in) p 203 2592 a(the) p 287 2592 a(absence) p
-466 2592 a(of) p 522 2592 a(this) p 617 2592 a(constructor.) 926
-2937 y(3) p eop
-PStoPSsaved restore
-userdict/PStoPSsaved save put
-PStoPSmatrix setmatrix
-595.000000 421.271378 translate
-90 rotate
-0.706651 dup scale
-userdict/PStoPSmatrix matrix currentmatrix put
-userdict/PStoPSclip{0 0 moveto
- 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto
- closepath}put initclip
-PStoPSxform concat
-4 3 bop Fi 11 168 a(Discussion) p Fk 11 261 a(Suc) o(h) p
-133 261 a(a) p 179 261 a(c) o(hange) p 345 261 a(has) p
-436 261 a(the) p 525 261 a(ma) s(jor) p 672 261 a(adv) m(an) o(tage) p
-907 261 a(of) p 967 261 a(b) q(oth) p 1087 261 a(reco) o(v) o(ering) p
-1324 261 a(principalit) o(y) p 1589 261 a(and) p 1688
-261 a(a) o(v) o(oiding) 11 321 y(unin) o(tuitiv) o(e) p
-266 321 a(error) p 392 321 a(messages.) p 640 321 a(Constrain) o(ts) p
-909 321 a(created) p 1087 321 a(in) p 1152 321 a(suc) o(h) p
-1269 321 a(a) p 1317 321 a(w) o(a) o(y) p 1423 321 a(are) p
-1512 321 a(v) o(ery) p 1626 321 a(ligh) o(t:) p 1772
-321 a(they) 11 381 y(alw) o(a) o(ys) p 165 381 a(app) q(ear) p
-325 381 a(inside) p 463 381 a(a) p 502 381 a(v) m(arian) o(t) p
-666 381 a(t) o(yp) q(e,) p 788 381 a(and) p 882 381 a(if) p
-926 381 a(the) p 1008 381 a(v) m(arian) o(t) p 1172 381
-a(t) o(yp) q(e) p 1281 381 a(do) q(es) p 1390 381 a(not) p
-1475 381 a(app) q(ear) p 1635 381 a(in) p 1691 381 a(the) p
-1774 381 a(\014nal) 11 441 y(t) o(yp) q(e) p 120 441
-a(sc) o(heme,) p 301 441 a(then) p 412 441 a(the) p 496
-441 a(constrain) o(t) p 725 441 a(can) p 815 441 a(b) q(e) p
-881 441 a(discarded) p 1098 441 a(safely) l(.) 84 501
-y(On) p 165 501 a(the) p 249 501 a(other) p 376 501 a(hand,) p
-512 501 a(there) p 637 501 a(are) p 718 501 a(t) o(w) o(o) p
-810 501 a(dra) o(wbac) o(ks.) p Fj 83 616 a(\017) p Fk
-133 616 a(Some) p 259 616 a(errors) p 393 616 a(will) p
-482 616 a(b) q(e) p 544 616 a(dela) o(y) o(ed) p 715
-616 a(longer) p 858 616 a(than) p 968 616 a(no) o(w,) p
-1080 616 a(un) o(til) p 1191 616 a(a) p 1228 616 a(construtor) p
-1460 616 a(is) p 1505 616 a(actually) p 1687 616 a(included) 133
-676 y(in) p Fg 189 676 a(L) p Fk(.) p 258 676 a(It) p
-311 676 a(is) p 360 676 a(not) p 446 676 a(clear) p 563
-676 a(ho) o(w) p 665 676 a(damageable) p 930 676 a(it) p
-979 676 a(is.) p Fj 83 777 a(\017) p Fk 133 777 a(While) p
-272 777 a(t) o(yp) q(e) p 378 777 a(inference) p 579
-777 a(is) p 625 777 a(simple) p 774 777 a(and) p 865
-777 a(costless) p 1036 777 a(for) p 1108 777 a(this) p
-1200 777 a(extension,) p 1426 777 a(simpli\014cation) p
-1724 777 a(of) p 1776 777 a(con-) 133 838 y(strain) o(ts) p
-310 838 a(|marking) p 551 838 a(constructors) p 830 838
-a(with) p 943 838 a(unsolv) m(able) p 1182 838 a(constrain) o(ts) p
-1432 838 a(as) p 1494 838 a(absen) o(t,) p 1663 838 a(and) p
-1760 838 a(elim-) 133 898 y(inating) p 300 898 a(redundan) o(t) p
-536 898 a(t) o(yp) q(es) p 667 898 a(in) p 726 898 a(constrain) o(ts|) p
-1025 898 a(is) p 1076 898 a(a) p 1119 898 a(bit) p 1197
-898 a(more) p 1320 898 a(exp) q(ensiv) o(e.) p 1565 898
-a(Also,) p 1691 898 a(allo) o(wing) 133 958 y(suc) o(h) p
-244 958 a(constrained) p 506 958 a(t) o(yp) q(es) p 637
-958 a(inside) p 777 958 a(signatures) p 1010 958 a(w) o(ould) p
-1154 958 a(mean) p 1286 958 a(ha) o(ving) p 1444 958
-a(to) p 1506 958 a(solv) o(e) p 1627 958 a(a) p 1669
-958 a(matc) o(hing) 133 1018 y(problem,) p 333 1018 a(whic) o(h) p
-469 1018 a(is) p 514 1018 a(exp) q(onen) o(tial) p 772
-1018 a(in) p 825 1018 a(the) p 906 1018 a(n) o(um) o(b) q(er) p
-1080 1018 a(of) p 1132 1018 a(connected) p 1356 1018
-a(constrain) o(ts) p 1600 1018 a(inside) p 1735 1018
-a(a) p 1772 1018 a(t) o(yp) q(e) 133 1078 y(sc) o(heme.) 84
-1193 y(Reasonably) p 340 1193 a(e\016cien) o(t) p 516
-1193 a(algorithms) p 754 1193 a(exist) p 866 1193 a(to) p
-922 1193 a(solv) o(e) p 1038 1193 a(these) p 1159 1193
-a(problems,) p 1379 1193 a(so) p 1435 1193 a(the) p 1515
-1193 a(di\016cult) o(y) p 1715 1193 a(is) p 1760 1193
-a(more) 11 1253 y(in) p 67 1253 a(the) p 151 1253 a(increased) p
-363 1253 a(complexit) o(y) p 611 1253 a(of) p 667 1253
-a(the) p 751 1253 a(t) o(yp) q(e-c) o(hec) o(k) o(er) p
-1031 1253 a(than) p 1145 1253 a(in) p 1202 1253 a(run-time) p
-1402 1253 a(cost.) p Fl 11 1397 a(Other) p 205 1397 a(features) p
-Fk 11 1490 a(Ob) s(jectiv) o(e) p 238 1490 a(Lab) q(el) p
-380 1490 a(con) o(tains) p 579 1490 a(t) o(w) o(o) p
-678 1490 a(other) p 812 1490 a(features:) p 1029 1490
-a(p) q(olymorphic) p 1318 1490 a(metho) q(ds) p 1521
-1490 a(and) p 1623 1490 a(t) o(yp) q(e-driv) o(en) 11
-1550 y(access) p 153 1550 a(of) p 208 1550 a(records.) p
-394 1550 a(Both) p 514 1550 a(of) p 568 1550 a(them) p
-692 1550 a(use) p 775 1550 a(the) p 857 1550 a(same) p
-978 1550 a(metho) q(d) p 1154 1550 a(of) p 1209 1550
-a(enforcing) p 1417 1550 a(principalit) o(y) p 1676 1550
-a(of) p 1730 1550 a(t) o(yping) 11 1610 y(through) p
-191 1610 a(tracing) p 351 1610 a(user) p 450 1610 a(pro) o(vided) p
-647 1610 a(t) o(yp) q(e) p 752 1610 a(information.) p
-1034 1610 a(With) p 1155 1610 a(this) p 1246 1610 a(tracing,) p
-1422 1610 a(their) p 1534 1610 a(implem) o(en) n(tation) 11
-1670 y(is) p 60 1670 a(v) o(ery) p 167 1670 a(easy) l(,) p
-283 1670 a(but) p 373 1670 a(without) p 554 1670 a(it) p
-603 1670 a(they) p 713 1670 a(lo) q(ose) p 834 1670 a(principalit) o(y)
-l(.) 84 1730 y(While) p 229 1730 a(these) p 357 1730
-a(features) p 543 1730 a(pro) o(vide) p 720 1730 a(some) p
-845 1730 a(comfort) p 1029 1730 a(in) p 1089 1730 a(writing) p
-1260 1730 a(user) p 1366 1730 a(programs,) p 1598 1730
-a(they) p 1711 1730 a(are) p 1795 1730 a(not) 11 1791
-y(strictly) p 182 1791 a(necessary) p 403 1791 a(for) p
-482 1791 a(the) p 571 1791 a(v) m(arious) p 742 1791
-a(libraries) p 934 1791 a(coming) p 1107 1791 a(with) p
-1223 1791 a(O'Labl) p 1391 1791 a(\(LablTk,) p 1602 1791
-a(LablGL) p 1787 1791 a(and) 11 1851 y(LablGTK\).) 926
-2937 y(4) p eop
-PStoPSsaved restore
-%%Trailer
-end
-userdict /end-hook known{end-hook}if
-%%EOF
+++ /dev/null
-Index: camlp4/Camlp4/Struct/Grammar/Delete.ml
-===================================================================
---- camlp4/Camlp4/Struct/Grammar/Delete.ml (revision 14037)
-+++ camlp4/Camlp4/Struct/Grammar/Delete.ml (working copy)
-@@ -35,17 +35,17 @@
- open Structure;
-
- value raise_rule_not_found entry symbols =
-- let to_string f x =
-+ let to_string : !'a. (_ -> 'a -> _) -> 'a -> _ = fun [f -> fun [x ->
- let buff = Buffer.create 128 in
- let ppf = Format.formatter_of_buffer buff in
- do {
- f ppf x;
- Format.pp_print_flush ppf ();
- Buffer.contents buff
-- } in
-- let entry = to_string Print.entry entry in
-- let symbols = to_string Print.print_rule symbols in
-- raise (Rule_not_found (symbols, entry))
-+ }]] in
-+ let entry = to_string Print.entry entry in
-+ let symbols = to_string Print.print_rule symbols in
-+ raise (Rule_not_found (symbols, entry))
- ;
-
- (* Deleting a rule *)
-Index: camlp4/boot/Camlp4.ml
-===================================================================
---- camlp4/boot/Camlp4.ml (revision 14037)
-+++ camlp4/boot/Camlp4.ml (working copy)
-@@ -18022,7 +18022,7 @@
- open Structure
-
- let raise_rule_not_found entry symbols =
-- let to_string f x =
-+ let to_string : 'a. (_ -> 'a -> _) -> 'a -> _ = fun f x ->
- let buff = Buffer.create 128 in
- let ppf = Format.formatter_of_buffer buff
- in
-Index: camlp4/Camlp4Filters/Camlp4FoldGenerator.ml
-===================================================================
---- camlp4/Camlp4Filters/Camlp4FoldGenerator.ml (revision 14037)
-+++ camlp4/Camlp4Filters/Camlp4FoldGenerator.ml (working copy)
-@@ -547,14 +547,18 @@
-
- value processor =
- let last = ref <:ctyp<>> in
-- let generate_class' generator default c s n =
-+ let generate_class'
-+ : !'a 'b. (_ -> 'a -> _ -> _ -> 'b) -> 'b -> 'a -> _ -> _ -> 'b =
-+ fun generator default c s n ->
- match s with
- [ "Fold" -> generator Fold c last.val n
- | "Map" -> generator Map c last.val n
- | "FoldMap" -> generator Fold_map c last.val n
- | _ -> default ]
- in
-- let generate_class_from_module_name generator c default m =
-+ let generate_class_from_module_name
-+ : !'a 'b. (_ -> 'a -> _ -> _ -> 'b) -> 'a -> 'b -> _ -> 'b =
-+ fun generator c default m ->
- try Scanf.sscanf m "Camlp4%[^G]Generator" begin fun m' ->
- try Scanf.sscanf m' "%[^0-9]%d" (generate_class' generator default c)
- with [ End_of_file | Scanf.Scan_failure _ -> generate_class' generator default c m' 1 ]
-Index: stdlib/arg.ml
-===================================================================
---- stdlib/arg.ml (revision 14037)
-+++ stdlib/arg.ml (working copy)
-@@ -106,7 +106,7 @@
- let l = Array.length argv in
- let b = Buffer.create 200 in
- let initpos = !current in
-- let stop error =
-+ let stop : 'a. _ -> 'a = fun error ->
- let progname = if initpos < l then argv.(initpos) else "(?)" in
- begin match error with
- | Unknown "-help" -> ()
-Index: stdlib/printf.ml
-===================================================================
---- stdlib/printf.ml (revision 14037)
-+++ stdlib/printf.ml (working copy)
-@@ -492,7 +492,7 @@
- Don't do this at home, kids. *)
- let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m =
-
-- let get_arg spec n =
-+ let get_arg : 'a. _ -> _ -> 'a = fun spec n ->
- Obj.magic (args.(Sformat.int_of_index (get_index spec n))) in
-
- let rec scan_positional n widths i =
-Index: stdlib/camlinternalOO.ml
-===================================================================
---- stdlib/camlinternalOO.ml (revision 14037)
-+++ stdlib/camlinternalOO.ml (working copy)
-@@ -349,7 +349,7 @@
- init_table.env_init <- env_init
-
- let dummy_class loc =
-- let undef = fun _ -> raise (Undefined_recursive_module loc) in
-+ let undef : 'a 'b.'a -> 'b = fun _ -> raise (Undefined_recursive_module loc) in
- (Obj.magic undef, undef, undef, Obj.repr 0)
-
- (**** Objects ****)
-@@ -527,7 +527,7 @@
- | Closure of closure
-
- let method_impl table i arr =
-- let next () = incr i; magic arr.(!i) in
-+ let next : 'a. unit -> 'a = fun () -> incr i; magic arr.(!i) in
- match next() with
- GetConst -> let x : t = next() in get_const x
- | GetVar -> let n = next() in get_var n
-Index: stdlib/scanf.ml
-===================================================================
---- stdlib/scanf.ml (revision 14037)
-+++ stdlib/scanf.ml (working copy)
-@@ -1324,10 +1324,11 @@
-
- let limr = Array.length rv - 1 in
-
-- let return v = Obj.magic v () in
-- let delay f x () = f x in
-- let stack f = delay (return f) in
-- let no_stack f _x = f in
-+ let return : 'a 'b 'c. ('a -> 'b) -> 'c = fun v -> Obj.magic v () in
-+ let delay : 'a 'b. ('a -> 'b) -> 'a -> unit -> 'b = fun f x () -> f x in
-+ let stack : 'a 'b 'd 'e. ('a -> 'b) -> 'd -> unit -> 'e =
-+ fun f -> delay (return f) in
-+ let no_stack : 'a 'b. 'a -> 'b -> 'a = fun f _x -> f in
-
- let rec scan fmt =
-
-@@ -1380,7 +1381,8 @@
- scan_conversion skip width_opt prec_opt ir f i
-
- and scan_conversion skip width_opt prec_opt ir f i =
-- let stack = if skip then no_stack else stack in
-+ let stack : 'b 'd. (unit -> 'b) -> 'd -> unit -> 'b =
-+ if skip then no_stack else stack in
- let width = int_of_width_opt width_opt in
- let prec = int_of_prec_opt prec_opt in
- match Sformat.get fmt i with
-Index: typing/typemod.ml
-===================================================================
---- typing/typemod.ml (revision 14037)
-+++ typing/typemod.ml (working copy)
-@@ -420,7 +420,7 @@
-
- (* let signature sg = List.map (fun item -> item.sig_type) sg *)
-
--let rec transl_modtype env smty =
-+let rec transl_modtype env smty : Typedtree.module_type =
- let loc = smty.pmty_loc in
- match smty.pmty_desc with
- Pmty_ident lid ->
-@@ -609,7 +609,7 @@
- List.fold_left
- (fun env (id, _, mty) -> Env.add_module id mty.mty_type env)
- env curr in
-- let transition env_c curr =
-+ let transition : 'a. _ -> (_ * _ * 'a) list -> _ = fun env_c curr ->
- List.map2
- (fun (_,smty) (id,id_loc,mty) -> (id, id_loc, transl_modtype env_c smty))
- sdecls curr in
-Index: typing/typecore.ml
-===================================================================
---- typing/typecore.ml (revision 14037)
-+++ typing/typecore.ml (working copy)
-@@ -1373,9 +1373,9 @@
-
- let ty_arrow gty ty = newty (Tarrow ("", instance_def gty, ty, Cok)) in
-
-- let bad_conversion fmt i c =
-+ let bad_conversion : 'a. string -> int -> char -> 'a = fun fmt i c ->
- raise (Error (loc, Env.empty, Bad_conversion (fmt, i, c))) in
-- let incomplete_format fmt =
-+ let incomplete_format : 'a. string -> 'a = fun fmt ->
- raise (Error (loc, Env.empty, Incomplete_format fmt)) in
-
- let rec type_in_format fmt =
-@@ -3238,7 +3238,7 @@
-
- (* Typing of let bindings *)
-
--and type_let ?(check = fun s -> Warnings.Unused_var s)
-+and type_let ?(global=false) ?(check = fun s -> Warnings.Unused_var s)
- ?(check_strict = fun s -> Warnings.Unused_var_strict s)
- env rec_flag spat_sexp_list scope allow =
- begin_def();
-@@ -3368,7 +3368,7 @@
- )
- pat_list
- in
-- let exp_list =
-+ let exp_gen_list =
- List.map2
- (fun (spat, sexp) (pat, slot) ->
- let sexp =
-@@ -3386,9 +3386,12 @@
- let exp = type_expect exp_env sexp ty' in
- end_def ();
- check_univars env true "definition" exp pat.pat_type vars;
-- {exp with exp_type = instance env exp.exp_type}
-- | _ -> type_expect exp_env sexp pat.pat_type)
-+ {exp with exp_type = instance env exp.exp_type}, true
-+ | _ ->
-+ type_expect exp_env sexp pat.pat_type,
-+ match sexp.pexp_desc with Pexp_ident _ -> true | _ -> false)
- spat_sexp_list pat_slot_list in
-+ let exp_list, gen_list = List.split exp_gen_list in
- current_slot := None;
- if is_recursive && not !rec_needed
- && Warnings.is_active Warnings.Unused_rec_flag then
-@@ -3399,10 +3402,12 @@
- pat_list exp_list;
- end_def();
- List.iter2
-- (fun pat exp ->
-- if not (is_nonexpansive exp) then
-+ (fun pat (exp, gen) ->
-+ if not (global || gen) then
-+ iter_pattern (fun pat -> generalize_structure pat.pat_type) pat
-+ else if not (is_nonexpansive exp) then
- iter_pattern (fun pat -> generalize_expansive env pat.pat_type) pat)
-- pat_list exp_list;
-+ pat_list exp_gen_list;
- List.iter
- (fun pat -> iter_pattern (fun pat -> generalize pat.pat_type) pat)
- pat_list;
-@@ -3413,7 +3418,7 @@
- let type_binding env rec_flag spat_sexp_list scope =
- Typetexp.reset_type_variables();
- let (pat_exp_list, new_env, unpacks) =
-- type_let
-+ type_let ~global:true
- ~check:(fun s -> Warnings.Unused_value_declaration s)
- ~check_strict:(fun s -> Warnings.Unused_value_declaration s)
- env rec_flag spat_sexp_list scope false
-Index: typing/includecore.ml
-===================================================================
---- typing/includecore.ml (revision 14037)
-+++ typing/includecore.ml (working copy)
-@@ -123,7 +123,8 @@
- | Record_representation of bool
-
- let report_type_mismatch0 first second decl ppf err =
-- let pr fmt = Format.fprintf ppf fmt in
-+ let pr : 'a. ('a, Format.formatter, unit) format -> 'a
-+ = fun fmt -> Format.fprintf ppf fmt in
- match err with
- Arity -> pr "They have different arities"
- | Privacy -> pr "A private type would be revealed"
-Index: ocamldoc/odoc_html.ml
-===================================================================
---- ocamldoc/odoc_html.ml (revision 14037)
-+++ ocamldoc/odoc_html.ml (working copy)
-@@ -508,7 +508,7 @@
- bs b "</table>\n"
-
- method html_of_Index_list b =
-- let index_if_not_empty l url m =
-+ let index_if_not_empty : 'a. 'a list -> _ = fun l url m ->
- match l with
- [] -> ()
- | _ -> bp b "<li><a href=\"%s\">%s</a></li>\n" url m
-@@ -977,7 +977,7 @@
- (** A function to build the header of pages. *)
- method prepare_header module_list =
- let f b ?(nav=None) ?(comments=[]) t =
-- let link_if_not_empty l m url =
-+ let link_if_not_empty : 'a. 'a list -> _ = fun l m url ->
- match l with
- [] -> ()
- | _ ->
-Index: bytecomp/translmod.ml
-===================================================================
---- bytecomp/translmod.ml (revision 14037)
-+++ bytecomp/translmod.ml (working copy)
-@@ -773,7 +773,8 @@
- Lprim(Psetglobal target_name, [Lprim(Pmakeblock(0, Immutable), components)])
-
- let transl_store_package component_names target_name coercion =
-- let rec make_sequence fn pos arg =
-+ let rec make_sequence : 'a. (int -> 'a -> _) -> int -> 'a list -> _ =
-+ fun fn pos arg ->
- match arg with
- [] -> lambda_unit
- | hd :: tl -> Lsequence(fn pos hd, make_sequence fn (pos + 1) tl) in
-Index: otherlibs/labltk/jpf/jpf_font.ml
-===================================================================
---- otherlibs/labltk/jpf/jpf_font.ml (revision 14037)
-+++ otherlibs/labltk/jpf/jpf_font.ml (working copy)
-@@ -131,7 +131,7 @@
- }
-
- let string_of_pattern =
-- let pat f = function
-+ let pat : 'a. ('a -> string) -> 'a option -> string = fun f -> function
- Some x -> f x
- | None -> "*"
- in
-Index: otherlibs/labltk/browser/searchid.ml
-===================================================================
---- otherlibs/labltk/browser/searchid.ml (revision 14037)
-+++ otherlibs/labltk/browser/searchid.ml (working copy)
-@@ -396,7 +396,7 @@
- let search_string_symbol text =
- if text = "" then [] else
- let lid = snd (longident_of_string text) [] in
-- let try_lookup f k =
-+ let try_lookup : 'a. _ -> 'a -> (_ * 'a) list = fun f k ->
- try let _ = f lid Env.initial in [lid, k]
- with Not_found | Env.Error _ -> []
- in
-Index: otherlibs/labltk/browser/setpath.ml
-===================================================================
---- otherlibs/labltk/browser/setpath.ml (revision 14037)
-+++ otherlibs/labltk/browser/setpath.ml (working copy)
-@@ -117,12 +117,12 @@
- bind_space_toggle dirbox;
- bind_space_toggle pathbox;
-
-- let add_paths _ =
-+ let add_paths : 'a. 'a -> unit = fun _ ->
- add_to_path pathbox ~base:!current_dir
- ~dirs:(List.map (Listbox.curselection dirbox)
- ~f:(fun x -> Listbox.get dirbox ~index:x));
- Listbox.selection_clear dirbox ~first:(`Num 0) ~last:`End
-- and remove_paths _ =
-+ and remove_paths : 'a. 'a -> unit = fun _ ->
- remove_path pathbox
- ~dirs:(List.map (Listbox.curselection pathbox)
- ~f:(fun x -> Listbox.get pathbox ~index:x))
-Index: otherlibs/labltk/browser/viewer.ml
-===================================================================
---- otherlibs/labltk/browser/viewer.ml (revision 14037)
-+++ otherlibs/labltk/browser/viewer.ml (working copy)
-@@ -507,7 +507,8 @@
- if i < 3 then Listbox.delete box ~first:(`Num 0) ~last:`End
- else destroy fm
- done;
-- let rec firsts n = function [] -> []
-+ let rec firsts : 'a. int -> 'a list -> 'a list = fun n -> function
-+ [] -> []
- | a :: l -> if n > 0 then a :: firsts (pred n) l else [] in
- shown_paths <- firsts (n-1) shown_paths;
- boxes <- firsts (max 3 n) boxes
-Index: otherlibs/labltk/frx/frx_req.ml
-===================================================================
---- otherlibs/labltk/frx/frx_req.ml (revision 14037)
-+++ otherlibs/labltk/frx/frx_req.ml (working copy)
-@@ -40,7 +40,7 @@
- let e =
- Entry.create t [Relief Sunken; TextVariable memory; TextWidth len] in
-
-- let activate _ =
-+ let activate : 'a. 'a -> unit = fun _ ->
- let v = Entry.get e in
- Grab.release t; (* because of wm *)
- destroy t; (* so action can call open_simple *)
-@@ -77,7 +77,7 @@
-
- let waiting = Textvariable.create_temporary t in
-
-- let activate _ =
-+ let activate : 'a. 'a -> unit = fun _ ->
- Grab.release t; (* because of wm *)
- destroy t; (* so action can call open_simple *)
- Textvariable.set waiting "1" in
-@@ -125,7 +125,7 @@
- Listbox.insert lb End elements;
-
- (* activation: we have to break() because we destroy the requester *)
-- let activate _ =
-+ let activate : 'a. 'a -> unit = fun _ ->
- let l = List.map (Listbox.get lb) (Listbox.curselection lb) in
- Grab.release t;
- destroy t;
-Index: otherlibs/labltk/support/rawwidget.ml
-===================================================================
---- otherlibs/labltk/support/rawwidget.ml (revision 14037)
-+++ otherlibs/labltk/support/rawwidget.ml (working copy)
-@@ -67,7 +67,7 @@
- (* This one is always created by opentk *)
- let default_toplevel =
- let wname = "." in
-- let w = Typed (wname, "toplevel") in
-+ let w : 'a. 'a raw_widget = Typed (wname, "toplevel") in
- Hashtbl.add table wname w;
- w
-
-@@ -145,7 +145,7 @@
- then "." ^ name
- else parentpath ^ "." ^ name
- in
-- let w = Typed(path,clas) in
-+ let w :'a. 'a raw_widget = Typed(path,clas) in
- Hashtbl.add table path w;
- w
-
-Index: ocamlbuild/rule.ml
-===================================================================
---- ocamlbuild/rule.ml (revision 14037)
-+++ ocamlbuild/rule.ml (working copy)
-@@ -260,7 +260,8 @@
- which is deprecated and ignored."
- name
- in
-- let res_add import xs xopt =
-+ let res_add : 'b. ('a -> 'b) -> 'a list -> 'a option -> 'b list =
-+ fun import xs xopt ->
- let init =
- match xopt with
- | None -> []
-Index: ocamlbuild/main.ml
-===================================================================
---- ocamlbuild/main.ml (revision 14037)
-+++ ocamlbuild/main.ml (working copy)
-@@ -50,7 +50,7 @@
- let show_documentation () =
- let rules = Rule.get_rules () in
- let flags = Flags.get_flags () in
-- let pp fmt = Log.raw_dprintf (-1) fmt in
-+ let pp : 'a. ('a,_,_) format -> 'a = fun fmt -> Log.raw_dprintf (-1) fmt in
- List.iter begin fun rule ->
- pp "%a@\n@\n" (Rule.pretty_print Resource.print_pattern) rule
- end rules;
+++ /dev/null
-? objvariants-3.09.1.diffs
-? objvariants.diffs
-Index: btype.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/btype.ml,v
-retrieving revision 1.37.4.1
-diff -u -r1.37.4.1 btype.ml
---- btype.ml 5 Dec 2005 13:18:42 -0000 1.37.4.1
-+++ btype.ml 16 Jan 2006 02:23:14 -0000
-@@ -177,7 +177,8 @@
- Tvariant row -> iter_row f row
- | Tvar | Tunivar | Tsubst _ | Tconstr _ ->
- Misc.may (fun (_,l) -> List.iter f l) row.row_name;
-- List.iter f row.row_bound
-+ List.iter f row.row_bound;
-+ List.iter (fun (s,k,t) -> f t) row.row_object
- | _ -> assert false
-
- let iter_type_expr f ty =
-@@ -224,7 +225,9 @@
- | Some (path, tl) -> Some (path, List.map f tl) in
- { row_fields = fields; row_more = more;
- row_bound = !bound; row_fixed = row.row_fixed && fixed;
-- row_closed = row.row_closed; row_name = name; }
-+ row_closed = row.row_closed; row_name = name;
-+ row_object = List.map (fun (s,k,t) -> (s,k,f t)) row.row_object;
-+ }
-
- let rec copy_kind = function
- Fvar{contents = Some k} -> copy_kind k
-Index: ctype.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v
-retrieving revision 1.197.2.6
-diff -u -r1.197.2.6 ctype.ml
---- ctype.ml 15 Dec 2005 02:28:38 -0000 1.197.2.6
-+++ ctype.ml 16 Jan 2006 02:23:15 -0000
-@@ -1421,7 +1421,7 @@
- newgenty
- (Tvariant
- {row_fields = fields; row_closed = closed; row_more = newvar();
-- row_bound = []; row_fixed = false; row_name = None })
-+ row_bound = []; row_fixed = false; row_name = None; row_object=[]})
-
- (**** Unification ****)
-
-@@ -1724,8 +1724,11 @@
- else None
- in
- let bound = row1.row_bound @ row2.row_bound in
-+ let opairs, _, miss2 = associate_fields row1.row_object row2.row_object in
-+ let row_object = row1.row_object @ miss2 in
- let row0 = {row_fields = []; row_more = more; row_bound = bound;
-- row_closed = closed; row_fixed = fixed; row_name = name} in
-+ row_closed = closed; row_fixed = fixed; row_name = name;
-+ row_object = row_object } in
- let set_more row rest =
- let rest =
- if closed then
-@@ -1758,6 +1761,18 @@
- raise (Unify ((mkvariant [l,f1] true,
- mkvariant [l,f2] true) :: trace)))
- pairs;
-+ List.iter (fun (s,_,ty1,_,ty2) -> unify env ty1 ty2) opairs;
-+ if row_object <> [] then begin
-+ List.iter
-+ (fun (l,f) ->
-+ match row_field_repr f with
-+ Rpresent (Some ty) ->
-+ let fi = build_fields generic_level row_object (newgenvar()) in
-+ unify env (newgenty (Tobject (fi, ref None))) ty
-+ | Rpresent None -> raise (Unify [])
-+ | _ -> ())
-+ (row_repr row1).row_fields
-+ end;
- with exn ->
- log_type rm1; rm1.desc <- md1; log_type rm2; rm2.desc <- md2; raise exn
- end
-@@ -2789,7 +2804,8 @@
- let row =
- { row_fields = List.map fst fields; row_more = newvar();
- row_bound = !bound; row_closed = posi; row_fixed = false;
-- row_name = if c > Unchanged then None else row.row_name }
-+ row_name = if c > Unchanged then None else row.row_name;
-+ row_object = [] }
- in
- (newty (Tvariant row), Changed)
- | Tobject (t1, _) ->
-Index: oprint.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/oprint.ml,v
-retrieving revision 1.22
-diff -u -r1.22 oprint.ml
---- oprint.ml 23 Mar 2005 03:08:37 -0000 1.22
-+++ oprint.ml 16 Jan 2006 02:23:15 -0000
-@@ -185,7 +185,7 @@
- fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields
- | Otyp_stuff s -> fprintf ppf "%s" s
- | Otyp_var (ng, s) -> fprintf ppf "'%s%s" (if ng then "_" else "") s
-- | Otyp_variant (non_gen, row_fields, closed, tags) ->
-+ | Otyp_variant (non_gen, row_fields, closed, tags, obj) ->
- let print_present ppf =
- function
- None | Some [] -> ()
-@@ -198,12 +198,17 @@
- ppf fields
- | Ovar_name (id, tyl) ->
- fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id
-+ and print_object ppf obj =
-+ if obj <> [] then
-+ fprintf ppf "@ as @[<2>< %a >@]" (print_fields (Some false)) obj
- in
-- fprintf ppf "%s[%s@[<hv>@[<hv>%a@]%a ]@]" (if non_gen then "_" else "")
-+ fprintf ppf "%s[%s@[<hv>@[<hv>%a@]%a%a ]@]"
-+ (if non_gen then "_" else "")
- (if closed then if tags = None then " " else "< "
- else if tags = None then "> " else "? ")
- print_fields row_fields
- print_present tags
-+ print_object obj
- | Otyp_alias _ | Otyp_poly _ | Otyp_arrow _ | Otyp_tuple _ as ty ->
- fprintf ppf "@[<1>(%a)@]" print_out_type ty
- | Otyp_abstract | Otyp_sum _ | Otyp_record _ | Otyp_manifest (_, _) -> ()
-Index: outcometree.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/outcometree.mli,v
-retrieving revision 1.14
-diff -u -r1.14 outcometree.mli
---- outcometree.mli 23 Mar 2005 03:08:37 -0000 1.14
-+++ outcometree.mli 16 Jan 2006 02:23:15 -0000
-@@ -59,6 +59,7 @@
- | Otyp_var of bool * string
- | Otyp_variant of
- bool * out_variant * bool * (string list) option
-+ * (string * out_type) list
- | Otyp_poly of string list * out_type
- and out_variant =
- | Ovar_fields of (string * bool * out_type list) list
-Index: printtyp.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/printtyp.ml,v
-retrieving revision 1.139.2.2
-diff -u -r1.139.2.2 printtyp.ml
---- printtyp.ml 7 Dec 2005 23:37:27 -0000 1.139.2.2
-+++ printtyp.ml 16 Jan 2006 02:23:15 -0000
-@@ -244,7 +244,10 @@
- visited_objects := px :: !visited_objects;
- match row.row_name with
- | Some(p, tyl) when namable_row row ->
-- List.iter (mark_loops_rec visited) tyl
-+ List.iter (mark_loops_rec visited) tyl;
-+ if not (static_row row) then
-+ List.iter (fun (s,k,t) -> mark_loops_rec visited t)
-+ row.row_object
- | _ ->
- iter_row (mark_loops_rec visited) {row with row_bound = []}
- end
-@@ -343,25 +346,27 @@
- | _ -> false)
- fields in
- let all_present = List.length present = List.length fields in
-+ let static = row.row_closed && all_present in
-+ let obj =
-+ if static then [] else
-+ List.map (fun (s,k,t) -> (s, tree_of_typexp sch t)) row.row_object
-+ in
-+ let tags = if all_present then None else Some (List.map fst present) in
- begin match row.row_name with
- | Some(p, tyl) when namable_row row ->
- let id = tree_of_path p in
- let args = tree_of_typlist sch tyl in
-- if row.row_closed && all_present then
-+ if static then
- Otyp_constr (id, args)
- else
- let non_gen = is_non_gen sch px in
-- let tags =
-- if all_present then None else Some (List.map fst present) in
- Otyp_variant (non_gen, Ovar_name(tree_of_path p, args),
-- row.row_closed, tags)
-+ row.row_closed, tags, obj)
- | _ ->
-- let non_gen =
-- not (row.row_closed && all_present) && is_non_gen sch px in
-+ let non_gen = not static && is_non_gen sch px in
- let fields = List.map (tree_of_row_field sch) fields in
-- let tags =
-- if all_present then None else Some (List.map fst present) in
-- Otyp_variant (non_gen, Ovar_fields fields, row.row_closed, tags)
-+ Otyp_variant (non_gen, Ovar_fields fields, row.row_closed,
-+ tags, obj)
- end
- | Tobject (fi, nm) ->
- tree_of_typobject sch fi nm
-Index: typecore.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v
-retrieving revision 1.176.2.2
-diff -u -r1.176.2.2 typecore.ml
---- typecore.ml 11 Dec 2005 09:56:33 -0000 1.176.2.2
-+++ typecore.ml 16 Jan 2006 02:23:15 -0000
-@@ -170,7 +170,8 @@
- (* Force check of well-formedness *)
- unify_pat pat.pat_env pat
- (newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false;
-- row_bound=[]; row_fixed=false; row_name=None}));
-+ row_bound=[]; row_fixed=false; row_name=None;
-+ row_object=[]}));
- | _ -> ()
-
- let rec iter_pattern f p =
-@@ -251,7 +252,7 @@
- let ty = may_map (build_as_type env) p' in
- newty (Tvariant{row_fields=[l, Rpresent ty]; row_more=newvar();
- row_bound=[]; row_name=None;
-- row_fixed=false; row_closed=false})
-+ row_fixed=false; row_closed=false; row_object=[]})
- | Tpat_record lpl ->
- let lbl = fst(List.hd lpl) in
- if lbl.lbl_private = Private then p.pat_type else
-@@ -318,7 +319,8 @@
- ([],[]) fields in
- let row =
- { row_fields = List.rev fields; row_more = newvar(); row_bound = !bound;
-- row_closed = false; row_fixed = false; row_name = Some (path, tyl) }
-+ row_closed = false; row_fixed = false; row_name = Some (path, tyl);
-+ row_object = [] }
- in
- let ty = newty (Tvariant row) in
- let gloc = {loc with Location.loc_ghost=true} in
-@@ -428,7 +430,8 @@
- row_closed = false;
- row_more = newvar ();
- row_fixed = false;
-- row_name = None } in
-+ row_name = None;
-+ row_object = [] } in
- rp {
- pat_desc = Tpat_variant(l, arg, row);
- pat_loc = sp.ppat_loc;
-@@ -976,7 +979,8 @@
- row_bound = [];
- row_closed = false;
- row_fixed = false;
-- row_name = None});
-+ row_name = None;
-+ row_object = []});
- exp_env = env }
- | Pexp_record(lid_sexp_list, opt_sexp) ->
- let ty = newvar() in
-@@ -1261,8 +1265,30 @@
- assert false
- end
- | _ ->
-- (Texp_send(obj, Tmeth_name met),
-- filter_method env met Public obj.exp_type)
-+ let obj, met_ty =
-+ match expand_head env obj.exp_type with
-+ {desc = Tvariant _} ->
-+ let exp_ty = newvar () in
-+ let met_ty = filter_method env met Public exp_ty in
-+ let row =
-+ {row_fields=[]; row_more=newvar();
-+ row_bound=[]; row_closed=false;
-+ row_fixed=false; row_name=None;
-+ row_object=[met, Fpresent, met_ty]} in
-+ unify_exp env obj (newty (Tvariant row));
-+ let prim = Primitive.parse_declaration 1 ["%field1"] in
-+ let ty = newty(Tarrow("", obj.exp_type, exp_ty, Cok)) in
-+ let vd = {val_type = ty; val_kind = Val_prim prim} in
-+ let esnd =
-+ {exp_desc=Texp_ident(Path.Pident(Ident.create"snd"), vd);
-+ exp_loc = Location.none; exp_type = ty; exp_env = env}
-+ in
-+ ({obj with exp_type = exp_ty;
-+ exp_desc = Texp_apply(esnd,[Some obj, Required])},
-+ met_ty)
-+ | _ -> (obj, filter_method env met Public obj.exp_type)
-+ in
-+ (Texp_send(obj, Tmeth_name met), met_ty)
- in
- if !Clflags.principal then begin
- end_def ();
-Index: types.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/types.ml,v
-retrieving revision 1.25
-diff -u -r1.25 types.ml
---- types.ml 9 Dec 2004 12:40:53 -0000 1.25
-+++ types.ml 16 Jan 2006 02:23:15 -0000
-@@ -44,7 +44,9 @@
- row_bound: type_expr list;
- row_closed: bool;
- row_fixed: bool;
-- row_name: (Path.t * type_expr list) option }
-+ row_name: (Path.t * type_expr list) option;
-+ row_object: (string * field_kind * type_expr) list;
-+ }
-
- and row_field =
- Rpresent of type_expr option
-Index: types.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/types.mli,v
-retrieving revision 1.25
-diff -u -r1.25 types.mli
---- types.mli 9 Dec 2004 12:40:53 -0000 1.25
-+++ types.mli 16 Jan 2006 02:23:15 -0000
-@@ -43,7 +43,9 @@
- row_bound: type_expr list;
- row_closed: bool;
- row_fixed: bool;
-- row_name: (Path.t * type_expr list) option }
-+ row_name: (Path.t * type_expr list) option;
-+ row_object: (string * field_kind * type_expr) list;
-+ }
-
- and row_field =
- Rpresent of type_expr option
-Index: typetexp.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typetexp.ml,v
-retrieving revision 1.54
-diff -u -r1.54 typetexp.ml
---- typetexp.ml 22 Jul 2005 06:42:36 -0000 1.54
-+++ typetexp.ml 16 Jan 2006 02:23:15 -0000
-@@ -215,7 +215,8 @@
- in
- let row = { row_closed = true; row_fields = fields;
- row_bound = !bound; row_name = Some (path, args);
-- row_fixed = false; row_more = newvar () } in
-+ row_fixed = false; row_more = newvar ();
-+ row_object = [] } in
- let static = Btype.static_row row in
- let row =
- if static then row else
-@@ -262,7 +263,7 @@
- let mkfield l f =
- newty (Tvariant {row_fields=[l,f]; row_more=newvar();
- row_bound=[]; row_closed=true;
-- row_fixed=false; row_name=None}) in
-+ row_fixed=false; row_name=None; row_object=[]}) in
- let add_typed_field loc l f fields =
- try
- let f' = List.assoc l fields in
-@@ -345,7 +346,7 @@
- let row =
- { row_fields = List.rev fields; row_more = newvar ();
- row_bound = !bound; row_closed = closed;
-- row_fixed = false; row_name = !name } in
-+ row_fixed = false; row_name = !name; row_object = [] } in
- let static = Btype.static_row row in
- let row =
- if static then row else
+++ /dev/null
-(* use with [cvs update -r objvariants typing] *)
-
-let f (x : [> ]) = x#m 3;;
-let o = object method m x = x+2 end;;
-f (`A o);;
-let l = [`A o; `B(object method m x = x -2 method y = 3 end)];;
-List.map f l;;
-let g = function `A x -> x#m 3 | `B x -> x#y;;
-List.map g l;;
-fun x -> ignore (x=f); List.map x l;;
-fun (x : [< `A of _ | `B of _] -> int) -> ignore (x=f); List.map x l;;
-
-
-class cvar name =
- object
- method name = name
- method print ppf = Format.pp_print_string ppf name
- end
-
-type var = [`Var of cvar]
-
-class cint n =
- object
- method n = n
- method print ppf = Format.pp_print_int ppf n
- end
-
-class ['a] cadd (e1 : 'a) (e2 : 'a) =
- object
- constraint 'a = [> ]
- method e1 = e1
- method e2 = e2
- method print ppf = Format.fprintf ppf "(%t, %t)" e1#print e2#print
- end
-
-type 'a expr = [var | `Int of cint | `Add of 'a cadd]
-
-type expr1 = expr1 expr
-
-let print = Format.printf "%t@."
-
-let e1 : expr1 = `Add (new cadd (`Var (new cvar "x")) (`Int (new cint 2)))
+++ /dev/null
-Index: parsing/parser.mly
-===================================================================
---- parsing/parser.mly (revision 11929)
-+++ parsing/parser.mly (working copy)
-@@ -319,6 +319,11 @@
- let polyvars, core_type = varify_constructors newtypes core_type in
- (exp, ghtyp(Ptyp_poly(polyvars,core_type)))
-
-+let no_lessminus =
-+ List.map (fun (p,e,b) ->
-+ match b with None -> (p,e)
-+ | Some loc -> raise (Syntaxerr.Error (Syntaxerr.Other loc)))
-+
- %}
-
- /* Tokens */
-@@ -597,8 +602,9 @@
- structure_item:
- LET rec_flag let_bindings
- { match $3 with
-- [{ ppat_desc = Ppat_any; ppat_loc = _ }, exp] -> mkstr(Pstr_eval exp)
-- | _ -> mkstr(Pstr_value($2, List.rev $3)) }
-+ [{ ppat_desc = Ppat_any; ppat_loc = _ }, exp, None] ->
-+ mkstr(Pstr_eval exp)
-+ | _ -> mkstr(Pstr_value($2, no_lessminus (List.rev $3))) }
- | EXTERNAL val_ident COLON core_type EQUAL primitive_declaration
- { mkstr(Pstr_primitive($2, {pval_type = $4; pval_prim = $6})) }
- | TYPE type_declarations
-@@ -744,7 +750,7 @@
- | class_simple_expr simple_labeled_expr_list
- { mkclass(Pcl_apply($1, List.rev $2)) }
- | LET rec_flag let_bindings IN class_expr
-- { mkclass(Pcl_let ($2, List.rev $3, $5)) }
-+ { mkclass(Pcl_let ($2, no_lessminus (List.rev $3), $5)) }
- ;
- class_simple_expr:
- LBRACKET core_type_comma_list RBRACKET class_longident
-@@ -981,9 +987,15 @@
- | simple_expr simple_labeled_expr_list
- { mkexp(Pexp_apply($1, List.rev $2)) }
- | LET rec_flag let_bindings IN seq_expr
-- { mkexp(Pexp_let($2, List.rev $3, $5)) }
-+ { match $3 with
-+ | [pat, expr, Some loc] when $2 = Nonrecursive ->
-+ mkexp(Pexp_apply(
-+ {pexp_desc = Pexp_ident(Lident "bind"); pexp_loc = loc},
-+ ["", expr; "", ghexp(Pexp_function("", None, [pat, $5]))]))
-+ | bindings ->
-+ mkexp(Pexp_let($2, no_lessminus (List.rev $3), $5)) }
- | LET DOT simple_expr let_binding IN seq_expr
-- { let (pat, expr) = $4 in
-+ { let (pat, expr, _) = $4 in
- mkexp(Pexp_apply($3, ["", expr; "", ghexp(Pexp_function("", None, [pat, $6]))])) }
- | LET MODULE UIDENT module_binding IN seq_expr
- { mkexp(Pexp_letmodule($3, $4, $6)) }
-@@ -1197,14 +1209,17 @@
- ;
- let_binding:
- val_ident fun_binding
-- { (mkpatvar $1 1, $2) }
-+ { (mkpatvar $1 1, $2, None) }
- | val_ident COLON typevar_list DOT core_type EQUAL seq_expr
-- { (ghpat(Ppat_constraint(mkpatvar $1 1, ghtyp(Ptyp_poly($3,$5)))), $7) }
-+ { (ghpat(Ppat_constraint(mkpatvar $1 1, ghtyp(Ptyp_poly($3,$5)))), $7,
-+ None) }
- | val_ident COLON TYPE lident_list DOT core_type EQUAL seq_expr
- { let exp, poly = wrap_type_annotation $4 $6 $8 in
-- (ghpat(Ppat_constraint(mkpatvar $1 1, poly)), exp) }
-+ (ghpat(Ppat_constraint(mkpatvar $1 1, poly)), exp, None) }
- | pattern EQUAL seq_expr
-- { ($1, $3) }
-+ { ($1, $3, None) }
-+ | pattern LESSMINUS seq_expr
-+ { ($1, $3, Some (rhs_loc 2)) }
- ;
- fun_binding:
- strict_binding
+++ /dev/null
-Index: typing/typecore.ml
-===================================================================
---- typing/typecore.ml (revision 13003)
-+++ typing/typecore.ml (working copy)
-@@ -61,6 +61,7 @@
- | Not_a_packed_module of type_expr
- | Recursive_local_constraint of (type_expr * type_expr) list
- | Unexpected_existential
-+ | Pattern_newtype_non_closed of string * type_expr
-
- exception Error of Location.t * error
-
-@@ -121,7 +122,7 @@
- | Pexp_function (_, eo, pel) ->
- may expr eo; List.iter (fun (_, e) -> expr e) pel
- | Pexp_apply (e, lel) -> expr e; List.iter (fun (_, e) -> expr e) lel
-- | Pexp_let (_, pel, e)
-+ | Pexp_let (_, pel, e) -> expr e; List.iter (fun (_, e) -> expr e) pel
- | Pexp_match (e, pel)
- | Pexp_try (e, pel) -> expr e; List.iter (fun (_, e) -> expr e) pel
- | Pexp_array el
-@@ -1454,7 +1455,7 @@
-
- let duplicate_ident_types loc caselist env =
- let caselist =
-- List.filter (fun (pat, _) -> contains_gadt env pat) caselist in
-+ List.filter (fun ((_,pat), _) -> contains_gadt env pat) caselist in
- let idents = all_idents (List.map snd caselist) in
- List.fold_left
- (fun env s ->
-@@ -1552,7 +1553,7 @@
- exp_env = env }
- | Pexp_let(Nonrecursive, [spat, sval], sbody) when contains_gadt env spat ->
- type_expect ?in_function env
-- {sexp with pexp_desc = Pexp_match (sval, [spat, sbody])}
-+ {sexp with pexp_desc = Pexp_match (sval, [([],spat), sbody])}
- ty_expected
- | Pexp_let(rec_flag, spat_sexp_list, sbody) ->
- let scp =
-@@ -1572,20 +1573,21 @@
- exp_env = env }
- | Pexp_function (l, Some default, [spat, sbody]) ->
- let default_loc = default.pexp_loc in
-- let scases = [
-+ let scases = [([],
- {ppat_loc = default_loc;
- ppat_desc =
- Ppat_construct
- (mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))),
- Some {ppat_loc = default_loc;
- ppat_desc = Ppat_var (mknoloc "*sth*")},
-- false)},
-+ false)}),
- {pexp_loc = default_loc;
- pexp_desc = Pexp_ident(mknoloc (Longident.Lident "*sth*"))};
-+ ([],
- {ppat_loc = default_loc;
- ppat_desc = Ppat_construct
- (mknoloc (Longident.(Ldot (Lident "*predef*", "None"))),
-- None, false)},
-+ None, false)}),
- default;
- ] in
- let smatch = {
-@@ -1603,10 +1605,10 @@
- pexp_desc =
- Pexp_function (
- l, None,
-- [ {ppat_loc = loc;
-- ppat_desc = Ppat_var (mknoloc "*opt*")},
-+ [ ([], {ppat_loc = loc;
-+ ppat_desc = Ppat_var (mknoloc "*opt*")}),
- {pexp_loc = loc;
-- pexp_desc = Pexp_let(Default, [spat, smatch], sbody);
-+ pexp_desc = Pexp_let(Default, [snd spat, smatch], sbody);
- }
- ]
- )
-@@ -2733,10 +2735,10 @@
- and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
- (* ty_arg is _fully_ generalized *)
- let dont_propagate, has_gadts =
-- let patterns = List.map fst caselist in
-+ let patterns = List.map (fun ((_,p),_) -> p) caselist in
- List.exists contains_polymorphic_variant patterns,
-- List.exists (contains_gadt env) patterns in
--(* prerr_endline ( if has_gadts then "contains gadt" else "no gadt"); *)
-+ List.exists (contains_gadt env) patterns ||
-+ List.exists (fun ((l,_),_) -> l <> []) caselist in
- let ty_arg, ty_res, env =
- if has_gadts && not !Clflags.principal then
- correct_levels ty_arg, correct_levels ty_res,
-@@ -2761,9 +2763,21 @@
- Printtyp.raw_type_expr ty_arg; *)
- let pat_env_list =
- List.map
-- (fun (spat, sexp) ->
-+ (fun ((stypes,spat), sexp) ->
- let loc = sexp.pexp_loc in
- if !Clflags.principal then begin_def (); (* propagation of pattern *)
-+ (* For local types *)
-+ if stypes <> [] then begin_def ();
-+ let lev' = get_current_level () in
-+ let types = List.map (fun name -> name, newvar ~name ()) stypes in
-+ let env =
-+ List.fold_left (fun env (name, manifest) ->
-+ (* "Vanishing" definition *)
-+ let decl = new_declaration ~manifest (lev',lev') in
-+ snd (Env.enter_type name decl env))
-+ env types
-+ in
-+ (* Type the pattern itself *)
- let scope = Some (Annot.Idef loc) in
- let (pat, ext_env, force, unpacks) =
- let partial =
-@@ -2773,14 +2787,42 @@
- in type_pattern ~lev env spat scope ty_arg
- in
- pattern_force := force @ !pattern_force;
-+ (* For local types *)
-+ let ext_env =
-+ List.fold_left (fun env (name, ty) ->
-+ let ty = expand_head env ty in
-+ match ty.desc with
-+ Tconstr ((Path.Pident id as p), [], _) when
-+ let decl = Env.find_type p env in
-+ decl.type_newtype_level = Some (lev, lev) &&
-+ decl.type_kind = Type_abstract ->
-+ let (id', env) =
-+ Env.enter_type name (new_declaration (lev, lev)) env in
-+ let manifest = newconstr (Path.Pident id') [] in
-+ (* Make previous existential "vanish" *)
-+ Env.add_type id (new_declaration ~manifest (lev',lev')) env
-+ | _ ->
-+ if free_variables ty <> [] then
-+ raise (Error (spat.ppat_loc,
-+ Pattern_newtype_non_closed (name,ty)));
-+ let manifest = correct_levels ty in
-+ let decl = new_declaration ~manifest (lev, lev) in
-+ snd (Env.enter_type name decl env))
-+ ext_env types
-+ in
-+ if stypes <> [] then begin
-+ end_def ();
-+ iter_pattern (fun p -> unify_pat ext_env p (newvar())) pat;
-+ end;
-+ (* Principality *)
- let pat =
- if !Clflags.principal then begin
- end_def ();
- iter_pattern (fun {pat_type=t} -> generalize_structure t) pat;
-- { pat with pat_type = instance env pat.pat_type }
-+ { pat with pat_type = instance ext_env pat.pat_type }
- end else pat
- in
-- unify_pat env pat ty_arg';
-+ unify_pat ext_env pat ty_arg';
- (pat, (ext_env, unpacks)))
- caselist in
- (* Check for polymorphic variants to close *)
-@@ -2802,7 +2844,7 @@
- let in_function = if List.length caselist = 1 then in_function else None in
- let cases =
- List.map2
-- (fun (pat, (ext_env, unpacks)) (spat, sexp) ->
-+ (fun (pat, (ext_env, unpacks)) ((stypes,spat), sexp) ->
- let sexp = wrap_unpacks sexp unpacks in
- let ty_res' =
- if !Clflags.principal then begin
-@@ -2811,8 +2853,8 @@
- end_def ();
- generalize_structure ty; ty
- end
-- else if contains_gadt env spat then correct_levels ty_res
-- else ty_res in
-+ else if contains_gadt env spat || stypes <> []
-+ then correct_levels ty_res else ty_res in
- (* Format.printf "@[%i %i, ty_res' =@ %a@]@." lev (get_current_level())
- Printtyp.raw_type_expr ty_res'; *)
- let exp = type_expect ?in_function ext_env sexp ty_res' in
-@@ -3218,6 +3260,11 @@
- | Unexpected_existential ->
- fprintf ppf
- "Unexpected existential"
-+ | Pattern_newtype_non_closed (name, ty) ->
-+ reset_and_mark_loops ty;
-+ fprintf ppf
-+ "@[In this pattern, local type %s has been inferred as@ %a@ %s@]"
-+ name type_expr ty "It should not contain variables."
-
- let () =
- Env.add_delayed_check_forward := add_delayed_check
-Index: typing/ctype.mli
-===================================================================
---- typing/ctype.mli (revision 13003)
-+++ typing/ctype.mli (working copy)
-@@ -140,6 +140,9 @@
- the parameters [pi] and returns the corresponding instance of
- [t]. Exception [Cannot_apply] is raised in case of failure. *)
-
-+val new_declaration:
-+ ?manifest:type_expr -> ?loc:Location.t -> (int * int) -> type_declaration
-+
- val expand_head_once: Env.t -> type_expr -> type_expr
- val expand_head: Env.t -> type_expr -> type_expr
- val try_expand_once_opt: Env.t -> type_expr -> type_expr
-Index: typing/typeclass.ml
-===================================================================
---- typing/typeclass.ml (revision 13003)
-+++ typing/typeclass.ml (working copy)
-@@ -347,8 +347,8 @@
- let mkid s = mkloc s self_loc in
- { pexp_desc =
- Pexp_function ("", None,
-- [mkpat (Ppat_alias (mkpat (Ppat_var (mkid "self-*")),
-- mkid ("self-" ^ cl_num))),
-+ [([],mkpat (Ppat_alias (mkpat (Ppat_var (mkid "self-*")),
-+ mkid ("self-" ^ cl_num)))),
- expr]);
- pexp_loc = expr.pexp_loc }
-
-@@ -836,15 +836,15 @@
- | Pcl_fun (l, Some default, spat, sbody) ->
- let loc = default.pexp_loc in
- let scases =
-- [{ppat_loc = loc; ppat_desc = Ppat_construct (
-+ [([], {ppat_loc = loc; ppat_desc = Ppat_construct (
- mknoloc (Longident.(Ldot (Lident"*predef*", "Some"))),
- Some{ppat_loc = loc; ppat_desc = Ppat_var (mknoloc "*sth*")},
-- false)},
-+ false)}),
- {pexp_loc = loc; pexp_desc =
- Pexp_ident(mknoloc (Longident.Lident"*sth*"))};
-- {ppat_loc = loc; ppat_desc =
-+ ([], {ppat_loc = loc; ppat_desc =
- Ppat_construct(mknoloc (Longident.(Ldot (Lident"*predef*", "None"))),
-- None, false)},
-+ None, false)}),
- default] in
- let smatch =
- {pexp_loc = loc; pexp_desc =
-Index: typing/ctype.ml
-===================================================================
---- typing/ctype.ml (revision 13003)
-+++ typing/ctype.ml (working copy)
-@@ -696,6 +696,7 @@
- Path.binding_time p
-
- let rec update_level env level ty =
-+ (* Format.eprintf "update_level %d %a@." level !Btype.print_raw ty; *)
- let ty = repr ty in
- if ty.level > level then begin
- if Env.has_local_constraints env then begin
-@@ -1043,7 +1044,7 @@
- reified_var_counter := Vars.add s index !reified_var_counter;
- Printf.sprintf "%s#%d" s index
-
--let new_declaration newtype manifest =
-+let new_declaration ?manifest ?(loc=Location.none) newtype =
- {
- type_params = [];
- type_arity = 0;
-@@ -1051,7 +1052,7 @@
- type_private = Public;
- type_manifest = manifest;
- type_variance = [];
-- type_newtype_level = newtype;
-+ type_newtype_level = Some newtype;
- type_loc = Location.none;
- }
-
-@@ -1060,7 +1061,7 @@
- | None -> ()
- | Some (env, newtype_lev) ->
- let process existential =
-- let decl = new_declaration (Some (newtype_lev, newtype_lev)) None in
-+ let decl = new_declaration (newtype_lev, newtype_lev) in
- let name =
- match repr existential with
- {desc = Tvar (Some name)} -> name
-@@ -1808,7 +1809,7 @@
- let reify env t =
- let newtype_level = get_newtype_level () in
- let create_fresh_constr lev name =
-- let decl = new_declaration (Some (newtype_level, newtype_level)) None in
-+ let decl = new_declaration (newtype_level, newtype_level) in
- let name = get_new_abstract_name name in
- let (id, new_env) = Env.enter_type name decl !env in
- let t = newty2 lev (Tconstr (Path.Pident id,[],ref Mnil)) in
-@@ -2039,7 +2040,7 @@
- let add_gadt_equation env source destination =
- let destination = duplicate_type destination in
- let source_lev = find_newtype_level !env (Path.Pident source) in
-- let decl = new_declaration (Some source_lev) (Some destination) in
-+ let decl = new_declaration ~manifest:destination source_lev in
- let newtype_level = get_newtype_level () in
- env := Env.add_local_constraint source decl newtype_level !env;
- cleanup_abbrev ()
-Index: typing/typecore.mli
-===================================================================
---- typing/typecore.mli (revision 13003)
-+++ typing/typecore.mli (working copy)
-@@ -103,6 +103,7 @@
- | Not_a_packed_module of type_expr
- | Recursive_local_constraint of (type_expr * type_expr) list
- | Unexpected_existential
-+ | Pattern_newtype_non_closed of string * type_expr
-
- exception Error of Location.t * error
-
-Index: testsuite/tests/typing-gadts/test.ml.reference
-===================================================================
---- testsuite/tests/typing-gadts/test.ml.reference (revision 13003)
-+++ testsuite/tests/typing-gadts/test.ml.reference (working copy)
-@@ -293,4 +293,18 @@
- # type 'a ty = Int : int -> int ty
- # val f : 'a ty -> 'a = <fun>
- # val g : 'a ty -> 'a = <fun>
-+# - : unit -> unit list = <fun>
-+# - : unit list = []
-+# Characters 17-19:
-+ function type a. () -> ();; (* fail *)
-+ ^^
-+Error: In this pattern, local type a has been inferred as 'a
-+ It should not contain variables.
-+# type t = D : 'a * ('a -> int) -> t
-+# val f : t -> int = <fun>
-+# Characters 42-43:
-+ let f = function type b. D ((x:b), f) -> (f:t->int) x;; (* fail *)
-+ ^
-+Error: This expression has type b -> int
-+ but an expression was expected of type t -> int
- #
-Index: testsuite/tests/typing-gadts/test.ml
-===================================================================
---- testsuite/tests/typing-gadts/test.ml (revision 13003)
-+++ testsuite/tests/typing-gadts/test.ml (working copy)
-@@ -512,3 +512,15 @@
- let g : type a. a ty -> a =
- let () = () in
- fun x -> match x with Int y -> y;;
-+
-+(* Implicit type declarations in patterns *)
-+
-+(* alias *)
-+function type a. (() : a) -> ([] : a list);;
-+(function type a. (() : a) -> ([] : a list)) ();;
-+function type a. () -> ();; (* fail *)
-+
-+(* existential *)
-+type t = D : 'a * ('a -> int) -> t;;
-+let f = function type b. D ((x:b), f) -> (f:b->int) x;;
-+let f = function type b. D ((x:b), f) -> (f:t->int) x;; (* fail *)
-Index: testsuite/tests/typing-gadts/test.ml.principal.reference
-===================================================================
---- testsuite/tests/typing-gadts/test.ml.principal.reference (revision 13003)
-+++ testsuite/tests/typing-gadts/test.ml.principal.reference (working copy)
-@@ -306,4 +306,18 @@
- # type 'a ty = Int : int -> int ty
- # val f : 'a ty -> 'a = <fun>
- # val g : 'a ty -> 'a = <fun>
-+# - : unit -> unit list = <fun>
-+# - : unit list = []
-+# Characters 17-19:
-+ function type a. () -> ();; (* fail *)
-+ ^^
-+Error: In this pattern, local type a has been inferred as 'a
-+ It should not contain variables.
-+# type t = D : 'a * ('a -> int) -> t
-+# val f : t -> int = <fun>
-+# Characters 42-43:
-+ let f = function type b. D ((x:b), f) -> (f:t->int) x;; (* fail *)
-+ ^
-+Error: This expression has type b -> int
-+ but an expression was expected of type t -> int
- #
-Index: parsing/parser.mly
-===================================================================
---- parsing/parser.mly (revision 13003)
-+++ parsing/parser.mly (working copy)
-@@ -967,7 +967,7 @@
- | FUNCTION opt_bar match_cases
- { mkexp(Pexp_function("", None, List.rev $3)) }
- | FUN labeled_simple_pattern fun_def
-- { let (l,o,p) = $2 in mkexp(Pexp_function(l, o, [p, $3])) }
-+ { let (l,o,p) = $2 in mkexp(Pexp_function(l, o, [([],p), $3])) }
- | FUN LPAREN TYPE LIDENT RPAREN fun_def
- { mkexp(Pexp_newtype($4, $6)) }
- | MATCH seq_expr WITH opt_bar match_cases
-@@ -1187,18 +1187,18 @@
- EQUAL seq_expr
- { $2 }
- | labeled_simple_pattern fun_binding
-- { let (l, o, p) = $1 in ghexp(Pexp_function(l, o, [p, $2])) }
-+ { let (l, o, p) = $1 in ghexp(Pexp_function(l, o, [([],p), $2])) }
- | LPAREN TYPE LIDENT RPAREN fun_binding
- { mkexp(Pexp_newtype($3, $5)) }
- ;
- match_cases:
-- pattern match_action { [$1, $2] }
-- | match_cases BAR pattern match_action { ($3, $4) :: $1 }
-+ match_pattern match_action { [$1, $2] }
-+ | match_cases BAR match_pattern match_action { ($3, $4) :: $1 }
- ;
- fun_def:
- match_action { $1 }
- | labeled_simple_pattern fun_def
-- { let (l,o,p) = $1 in ghexp(Pexp_function(l, o, [p, $2])) }
-+ { let (l,o,p) = $1 in ghexp(Pexp_function(l, o, [([],p), $2])) }
- | LPAREN TYPE LIDENT RPAREN fun_def
- { mkexp(Pexp_newtype($3, $5)) }
- ;
-@@ -1245,6 +1245,10 @@
-
- /* Patterns */
-
-+match_pattern:
-+ pattern { [], $1 }
-+ | TYPE lident_list DOT pattern { $2, $4 }
-+;
- pattern:
- simple_pattern
- { $1 }
-Index: parsing/parsetree.mli
-===================================================================
---- parsing/parsetree.mli (revision 13003)
-+++ parsing/parsetree.mli (working copy)
-@@ -90,10 +90,11 @@
- Pexp_ident of Longident.t loc
- | Pexp_constant of constant
- | Pexp_let of rec_flag * (pattern * expression) list * expression
-- | Pexp_function of label * expression option * (pattern * expression) list
-+ | Pexp_function of
-+ label * expression option * ((string list * pattern) * expression) list
- | Pexp_apply of expression * (label * expression) list
-- | Pexp_match of expression * (pattern * expression) list
-- | Pexp_try of expression * (pattern * expression) list
-+ | Pexp_match of expression * ((string list * pattern) * expression) list
-+ | Pexp_try of expression * ((string list * pattern) * expression) list
- | Pexp_tuple of expression list
- | Pexp_construct of Longident.t loc * expression option * bool
- | Pexp_variant of label * expression option
-@@ -104,7 +105,8 @@
- | Pexp_ifthenelse of expression * expression * expression option
- | Pexp_sequence of expression * expression
- | Pexp_while of expression * expression
-- | Pexp_for of string loc * expression * expression * direction_flag * expression
-+ | Pexp_for of
-+ string loc * expression * expression * direction_flag * expression
- | Pexp_constraint of expression * core_type option * core_type option
- | Pexp_when of expression * expression
- | Pexp_send of expression * string
-Index: parsing/printast.ml
-===================================================================
---- parsing/printast.ml (revision 13003)
-+++ parsing/printast.ml (working copy)
-@@ -686,8 +686,9 @@
- line i ppf "%a\n" fmt_longident li;
- pattern (i+1) ppf p;
-
--and pattern_x_expression_case i ppf (p, e) =
-+and pattern_x_expression_case i ppf ((l,p), e) =
- line i ppf "<case>\n";
-+ list (i+1) string ppf l;
- pattern (i+1) ppf p;
- expression (i+1) ppf e;
-
+++ /dev/null
-(* $Id$ *)
-
-open Types
-
-let ignore_abbrevs ppf ab =
- let s = match ab with
- Mnil -> "Mnil"
- | Mlink _ -> "Mlink _"
- | Mcons _ -> "Mcons _"
- in
- Format.pp_print_string ppf s
+++ /dev/null
-Index: Changes
-===================================================================
---- Changes (revision 13157)
-+++ Changes (working copy)
-@@ -1,6 +1,11 @@
- Next version
- ------------
-
-+Type system:
-+- Propagate type information towards pattern-matching, even in the presence
-+ of polymorphic variants (discarding only information about possibly-present
-+ constructors)
-+
- Compilers:
- - PR#5861: raise an error when multiple private keywords are used in type declarations
- - PR#5634: parsetree rewriter (-ppx flag)
-Index: typing/typecore.ml
-===================================================================
---- typing/typecore.ml (revision 13157)
-+++ typing/typecore.ml (working copy)
-@@ -326,7 +326,7 @@
- | _ -> assert false
- in
- begin match row_field tag row with
-- | Rabsent -> assert false
-+ | Rabsent -> () (* assert false *)
- | Reither (true, [], _, e) when not row.row_closed ->
- set_row_field e (Rpresent None)
- | Reither (false, ty::tl, _, e) when not row.row_closed ->
-@@ -1657,6 +1657,28 @@
- sexp unpacks
-
- (* Helpers for type_cases *)
-+
-+let contains_variant_either ty =
-+ let rec loop ty =
-+ let ty = repr ty in
-+ if ty.level >= lowest_level then begin
-+ mark_type_node ty;
-+ match ty.desc with
-+ Tvariant row ->
-+ let row = row_repr row in
-+ if not row.row_fixed then
-+ List.iter
-+ (fun (_,f) ->
-+ match row_field_repr f with Reither _ -> raise Exit | _ -> ())
-+ row.row_fields;
-+ iter_row loop row
-+ | _ ->
-+ iter_type_expr loop ty
-+ end
-+ in
-+ try loop ty; unmark_type ty; false
-+ with Exit -> unmark_type ty; true
-+
- let iter_ppat f p =
- match p.ppat_desc with
- | Ppat_any | Ppat_var _ | Ppat_constant _
-@@ -1690,6 +1712,24 @@
- in
- try loop p; false with Exit -> true
-
-+let check_absent_variant env =
-+ iter_pattern
-+ (function {pat_desc = Tpat_variant (s, arg, row)} as pat ->
-+ let row = row_repr !row in
-+ if List.exists (fun (s',fi) -> s = s' && row_field_repr fi <> Rabsent)
-+ row.row_fields
-+ then () else
-+ let ty_arg =
-+ match arg with None -> [] | Some p -> [correct_levels p.pat_type] in
-+ let row' = {row_fields = [s, Reither(arg=None,ty_arg,true,ref None)];
-+ row_more = newvar (); row_bound = ();
-+ row_closed = false; row_fixed = false; row_name = None} in
-+ (* Should fail *)
-+ unify_pat env {pat with pat_type = newty (Tvariant row')}
-+ (correct_levels pat.pat_type)
-+ | _ -> ())
-+
-+
- let dummy_expr = {pexp_desc = Pexp_tuple []; pexp_loc = Location.none}
-
- (* Duplicate types of values in the environment *)
-@@ -3037,16 +3077,20 @@
-
- and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
- (* ty_arg is _fully_ generalized *)
-- let dont_propagate, has_gadts =
-- let patterns = List.map fst caselist in
-- List.exists contains_polymorphic_variant patterns,
-- List.exists (contains_gadt env) patterns in
-+ let patterns = List.map fst caselist in
-+ let erase_either =
-+ List.exists contains_polymorphic_variant patterns
-+ && contains_variant_either ty_arg
-+ and has_gadts = List.exists (contains_gadt env) patterns in
- (* prerr_endline ( if has_gadts then "contains gadt" else "no gadt"); *)
-- let ty_arg, ty_res, env =
-+ let ty_arg =
-+ if (has_gadts || erase_either) && not !Clflags.principal
-+ then correct_levels ty_arg else ty_arg
-+ and ty_res, env =
- if has_gadts && not !Clflags.principal then
-- correct_levels ty_arg, correct_levels ty_res,
-- duplicate_ident_types loc caselist env
-- else ty_arg, ty_res, env in
-+ correct_levels ty_res, duplicate_ident_types loc caselist env
-+ else ty_res, env
-+ in
- let lev, env =
- if has_gadts then begin
- (* raise level for existentials *)
-@@ -3072,10 +3116,10 @@
- let scope = Some (Annot.Idef loc) in
- let (pat, ext_env, force, unpacks) =
- let partial =
-- if !Clflags.principal then Some false else None in
-- let ty_arg =
-- if dont_propagate then newvar () else instance ?partial env ty_arg
-- in type_pattern ~lev env spat scope ty_arg
-+ if !Clflags.principal || erase_either
-+ then Some false else None in
-+ let ty_arg = instance ?partial env ty_arg in
-+ type_pattern ~lev env spat scope ty_arg
- in
- pattern_force := force @ !pattern_force;
- let pat =
-@@ -3134,7 +3178,11 @@
- else
- Partial
- in
-- add_delayed_check (fun () -> Parmatch.check_unused env cases);
-+ add_delayed_check
-+ (fun () ->
-+ List.iter (fun (pat, (env, _)) -> check_absent_variant env pat)
-+ pat_env_list;
-+ Parmatch.check_unused env cases);
- if has_gadts then begin
- end_def ();
- (* Ensure that existential types do not escape *)
-Index: typing/ctype.ml
-===================================================================
---- typing/ctype.ml (revision 13157)
-+++ typing/ctype.ml (working copy)
-@@ -981,6 +981,25 @@
- if keep then more else newty more.desc
- | _ -> assert false
- in
-+ (* Open row if partial for pattern and contains Reither *)
-+ let more', row =
-+ match partial with
-+ Some (free_univars, false) when row.row_closed
-+ && not row.row_fixed && TypeSet.is_empty (free_univars ty) ->
-+ let not_reither (_, f) =
-+ match row_field_repr f with
-+ Reither _ -> false
-+ | _ -> true
-+ in
-+ if List.for_all not_reither row.row_fields
-+ then (more', row) else
-+ (newty2 (if keep then more.level else !current_level)
-+ (Tvar None),
-+ {row_fields = List.filter not_reither row.row_fields;
-+ row_more = more; row_bound = ();
-+ row_closed = false; row_fixed = false; row_name = None})
-+ | _ -> (more', row)
-+ in
- (* Register new type first for recursion *)
- more.desc <- Tsubst(newgenty(Ttuple[more';t]));
- (* Return a new copy *)
-Index: testsuite/tests/typing-gadts/test.ml.reference
-===================================================================
---- testsuite/tests/typing-gadts/test.ml.reference (revision 13157)
-+++ testsuite/tests/typing-gadts/test.ml.reference (working copy)
-@@ -62,11 +62,11 @@
- ^^^^^^^^
- Error: This pattern matches values of type int t
- but a pattern was expected which matches values of type s t
--# Characters 224-237:
-- | `A, BoolLit _ -> ()
-- ^^^^^^^^^^^^^
--Error: This pattern matches values of type ([? `A ] as 'a) * bool t
-- but a pattern was expected which matches values of type 'a * int t
-+# module Polymorphic_variants :
-+ sig
-+ type _ t = IntLit : int -> int t | BoolLit : bool -> bool t
-+ val eval : [ `A ] * 's t -> unit
-+ end
- # module Propagation :
- sig
- type _ t = IntLit : int -> int t | BoolLit : bool -> bool t
-Index: testsuite/tests/typing-gadts/test.ml.principal.reference
-===================================================================
---- testsuite/tests/typing-gadts/test.ml.principal.reference (revision 13157)
-+++ testsuite/tests/typing-gadts/test.ml.principal.reference (working copy)
-@@ -62,11 +62,11 @@
- ^^^^^^^^
- Error: This pattern matches values of type int t
- but a pattern was expected which matches values of type s t
--# Characters 224-237:
-- | `A, BoolLit _ -> ()
-- ^^^^^^^^^^^^^
--Error: This pattern matches values of type ([? `A ] as 'a) * bool t
-- but a pattern was expected which matches values of type 'a * int t
-+# module Polymorphic_variants :
-+ sig
-+ type _ t = IntLit : int -> int t | BoolLit : bool -> bool t
-+ val eval : [ `A ] * 's t -> unit
-+ end
- # Characters 299-300:
- | BoolLit b -> b
- ^
+++ /dev/null
-Index: parsing/printast.mli
-===================================================================
---- parsing/printast.mli (revision 13955)
-+++ parsing/printast.mli (working copy)
-@@ -16,3 +16,4 @@
- val interface : formatter -> signature_item list -> unit;;
- val implementation : formatter -> structure_item list -> unit;;
- val top_phrase : formatter -> toplevel_phrase -> unit;;
-+val string_of_kind : ident_kind -> string;;
-Index: parsing/pprintast.ml
-===================================================================
---- parsing/pprintast.ml (revision 13955)
-+++ parsing/pprintast.ml (working copy)
-@@ -1192,8 +1192,10 @@
- | Pdir_none -> ()
- | Pdir_string (s) -> pp f "@ %S" s
- | Pdir_int (i) -> pp f "@ %d" i
-- | Pdir_ident (li) -> pp f "@ %a" self#longident li
-- | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b))
-+ | Pdir_ident {txt=li} -> pp f "@ %a" self#longident li
-+ | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b)
-+ | Pdir_show (k, {txt=li}) ->
-+ pp f "@ %s %a" (Printast.string_of_kind k) self#longident li)
-
- method toplevel_phrase f x =
- match x with
-Index: parsing/parser.mly
-===================================================================
---- parsing/parser.mly (revision 13955)
-+++ parsing/parser.mly (working copy)
-@@ -516,9 +516,9 @@
- | SEMISEMI EOF { [] }
- | SEMISEMI seq_expr use_file_tail { Ptop_def[mkstrexp $2] :: $3 }
- | SEMISEMI structure_item use_file_tail { Ptop_def[$2] :: $3 }
-- | SEMISEMI toplevel_directive use_file_tail { $2 :: $3 }
- | structure_item use_file_tail { Ptop_def[$1] :: $2 }
-- | toplevel_directive use_file_tail { $1 :: $2 }
-+ | SEMISEMI toplevel_directive SEMISEMI use_file_tail { $2 :: $4 }
-+ | toplevel_directive SEMISEMI use_file_tail { $1 :: $3 }
- ;
-
- /* Module expressions */
-@@ -1779,16 +1779,26 @@
- | FALSE { Lident "false" }
- | TRUE { Lident "true" }
- ;
-+ident_kind:
-+ VAL { Pkind_val }
-+ | TYPE { Pkind_type }
-+ | EXCEPTION { Pkind_exception }
-+ | MODULE { Pkind_module }
-+ | MODULE TYPE { Pkind_modtype }
-+ | CLASS { Pkind_class }
-+ | CLASS TYPE { Pkind_cltype }
-+;
-
- /* Toplevel directives */
-
- toplevel_directive:
-- SHARP ident { Ptop_dir($2, Pdir_none) }
-- | SHARP ident STRING { Ptop_dir($2, Pdir_string $3) }
-- | SHARP ident INT { Ptop_dir($2, Pdir_int $3) }
-- | SHARP ident val_longident { Ptop_dir($2, Pdir_ident $3) }
-- | SHARP ident FALSE { Ptop_dir($2, Pdir_bool false) }
-- | SHARP ident TRUE { Ptop_dir($2, Pdir_bool true) }
-+ SHARP ident { Ptop_dir($2, Pdir_none) }
-+ | SHARP ident STRING { Ptop_dir($2, Pdir_string $3) }
-+ | SHARP ident INT { Ptop_dir($2, Pdir_int $3) }
-+ | SHARP ident val_longident { Ptop_dir($2, Pdir_ident (mkrhs $3 3)) }
-+ | SHARP ident ident_kind any_longident { Ptop_dir($2, Pdir_show ($3, mkrhs $4 4)) }
-+ | SHARP ident FALSE { Ptop_dir($2, Pdir_bool false) }
-+ | SHARP ident TRUE { Ptop_dir($2, Pdir_bool true) }
- ;
-
- /* Miscellaneous */
-Index: parsing/parsetree.mli
-===================================================================
---- parsing/parsetree.mli (revision 13955)
-+++ parsing/parsetree.mli (working copy)
-@@ -294,6 +294,15 @@
-
- (* Toplevel phrases *)
-
-+type ident_kind =
-+ Pkind_val
-+ | Pkind_type
-+ | Pkind_exception
-+ | Pkind_module
-+ | Pkind_modtype
-+ | Pkind_class
-+ | Pkind_cltype
-+
- type toplevel_phrase =
- Ptop_def of structure
- | Ptop_dir of string * directive_argument
-@@ -302,5 +311,6 @@
- Pdir_none
- | Pdir_string of string
- | Pdir_int of int
-- | Pdir_ident of Longident.t
-+ | Pdir_ident of Longident.t Location.loc
-+ | Pdir_show of ident_kind * Longident.t Location.loc
- | Pdir_bool of bool
-Index: parsing/printast.ml
-===================================================================
---- parsing/printast.ml (revision 13955)
-+++ parsing/printast.ml (working copy)
-@@ -737,6 +737,16 @@
- core_type (i+1) ppf ct
- ;;
-
-+let string_of_kind = function
-+ Pkind_val -> "val"
-+ | Pkind_type -> "type"
-+ | Pkind_exception -> "exception"
-+ | Pkind_module -> "module"
-+ | Pkind_modtype -> "module type"
-+ | Pkind_class -> "class"
-+ | Pkind_cltype -> "class type"
-+;;
-+
- let rec toplevel_phrase i ppf x =
- match x with
- | Ptop_def (s) ->
-@@ -751,7 +761,9 @@
- | Pdir_none -> line i ppf "Pdir_none\n"
- | Pdir_string (s) -> line i ppf "Pdir_string \"%s\"\n" s;
- | Pdir_int (i) -> line i ppf "Pdir_int %d\n" i;
-- | Pdir_ident (li) -> line i ppf "Pdir_ident %a\n" fmt_longident li;
-+ | Pdir_ident {txt=li} -> line i ppf "Pdir_ident %a\n" fmt_longident li;
-+ | Pdir_show (kind,{txt=li}) ->
-+ line i ppf "Pdir_show %s %a\n" (string_of_kind kind) fmt_longident li;
- | Pdir_bool (b) -> line i ppf "Pdir_bool %s\n" (string_of_bool b);
- ;;
-
-Index: toplevel/opttoploop.ml
-===================================================================
---- toplevel/opttoploop.ml (revision 13955)
-+++ toplevel/opttoploop.ml (working copy)
-@@ -53,6 +53,7 @@
- | Directive_string of (string -> unit)
- | Directive_int of (int -> unit)
- | Directive_ident of (Longident.t -> unit)
-+ | Directive_show of (ident_kind -> Longident.t -> unit)
- | Directive_bool of (bool -> unit)
-
-
-@@ -270,6 +271,7 @@
- | (Directive_string f, Pdir_string s) -> f s; true
- | (Directive_int f, Pdir_int n) -> f n; true
- | (Directive_ident f, Pdir_ident lid) -> f lid; true
-+ | (Directive_show f, Pdir_show (kind,lid)) -> f kind lid; true
- | (Directive_bool f, Pdir_bool b) -> f b; true
- | (_, _) ->
- fprintf ppf "Wrong type of argument for directive `%s'.@." dir_name;
-Index: toplevel/topdirs.ml
-===================================================================
---- toplevel/topdirs.ml (revision 13955)
-+++ toplevel/topdirs.ml (working copy)
-@@ -15,6 +15,7 @@
- open Format
- open Misc
- open Longident
-+open Parsetree
- open Types
- open Cmo_format
- open Trace
-@@ -191,9 +192,9 @@
- Ctype.generalize ty_arg;
- ty_arg
-
--let find_printer_type ppf lid =
-+let find_printer_type ppf {Location.loc; txt=lid} =
- try
-- let (path, desc) = Env.lookup_value lid !toplevel_env in
-+ let (path, desc) = Typetexp.find_value !toplevel_env loc lid in
- let (ty_arg, is_old_style) =
- try
- (match_printer_type ppf desc "printer_type_new", false)
-@@ -201,12 +202,12 @@
- (match_printer_type ppf desc "printer_type_old", true) in
- (ty_arg, path, is_old_style)
- with
-- | Not_found ->
-- fprintf ppf "Unbound value %a.@." Printtyp.longident lid;
-+ Typetexp.Error _ as exn ->
-+ Errors.report_error ppf exn;
- raise Exit
- | Ctype.Unify _ ->
- fprintf ppf "%a has a wrong type for a printing function.@."
-- Printtyp.longident lid;
-+ Printtyp.longident lid;
- raise Exit
-
- let dir_install_printer ppf lid =
-@@ -227,7 +228,7 @@
- begin try
- remove_printer path
- with Not_found ->
-- fprintf ppf "No printer named %a.@." Printtyp.longident lid
-+ fprintf ppf "No printer named %a.@." Printtyp.longident lid.Location.txt
- end
- with Exit -> ()
-
-@@ -244,9 +245,9 @@
- get_code_pointer
- (Obj.repr (fun arg -> Trace.print_trace (current_environment()) arg))
-
--let dir_trace ppf lid =
-+let dir_trace ppf {Location.loc; txt=lid} =
- try
-- let (path, desc) = Env.lookup_value lid !toplevel_env in
-+ let (path, desc) = Typetexp.find_value !toplevel_env loc lid in
- (* Check if this is a primitive *)
- match desc.val_kind with
- | Val_prim p ->
-@@ -278,11 +279,11 @@
- fprintf ppf "%a is now traced.@." Printtyp.longident lid
- end else fprintf ppf "%a is not a function.@." Printtyp.longident lid
- with
-- | Not_found -> fprintf ppf "Unbound value %a.@." Printtyp.longident lid
-+ Typetexp.Error _ as exn -> Errors.report_error ppf exn
-
--let dir_untrace ppf lid =
-+let dir_untrace ppf {Location.loc; txt=lid} =
- try
-- let (path, desc) = Env.lookup_value lid !toplevel_env in
-+ let (path, desc) = Typetexp.find_value !toplevel_env loc lid in
- let rec remove = function
- | [] ->
- fprintf ppf "%a was not traced.@." Printtyp.longident lid;
-@@ -295,7 +296,7 @@
- end else f :: remove rem in
- traced_functions := remove !traced_functions
- with
-- | Not_found -> fprintf ppf "Unbound value %a.@." Printtyp.longident lid
-+ Typetexp.Error _ as exn -> Errors.report_error ppf exn
-
- let dir_untrace_all ppf () =
- List.iter
-@@ -305,10 +306,74 @@
- !traced_functions;
- traced_functions := []
-
-+(* Warnings *)
-+
- let parse_warnings ppf iserr s =
- try Warnings.parse_options iserr s
- with Arg.Bad err -> fprintf ppf "%s.@." err
-
-+(* Typing information *)
-+
-+let rec trim_modtype = function
-+ Mty_signature _ -> Mty_signature []
-+ | Mty_functor (id, mty, mty') ->
-+ Mty_functor (id, mty, trim_modtype mty')
-+ | Mty_ident _ as mty -> mty
-+
-+let trim_signature = function
-+ Mty_signature sg ->
-+ Mty_signature
-+ (List.map
-+ (function
-+ Sig_module (id, mty, rs) ->
-+ Sig_module (id, trim_modtype mty, rs)
-+ (*| Sig_modtype (id, Modtype_manifest mty) ->
-+ Sig_modtype (id, Modtype_manifest (trim_modtype mty))*)
-+ | item -> item)
-+ sg)
-+ | mty -> mty
-+
-+let dir_show ppf kind {Location.loc; txt=lid} =
-+ let env = !Toploop.toplevel_env in
-+ try
-+ let id =
-+ let s = match lid with
-+ Longident.Lident s -> s
-+ | Longident.Ldot (_,s) -> s
-+ | Longident.Lapply _ -> failwith "invalid"
-+ in Ident.create_persistent s
-+ in
-+ let item =
-+ match kind with
-+ Pkind_val ->
-+ let path, desc = Typetexp.find_value env loc lid in
-+ Sig_value (id, desc)
-+ | Pkind_type ->
-+ let path, desc = Typetexp.find_type env loc lid in
-+ Sig_type (id, desc, Trec_not)
-+ | Pkind_exception ->
-+ let desc = Typetexp.find_constructor env loc lid in
-+ Sig_exception (id, {exn_args=desc.cstr_args; exn_loc=Location.none})
-+ | Pkind_module ->
-+ let path, desc = Typetexp.find_module env loc lid in
-+ Sig_module (id, trim_signature desc, Trec_not)
-+ | Pkind_modtype ->
-+ let path, desc = Typetexp.find_modtype env loc lid in
-+ Sig_modtype (id, desc)
-+ | Pkind_class ->
-+ let path, desc = Typetexp.find_class env loc lid in
-+ Sig_class (id, desc, Trec_not)
-+ | Pkind_cltype ->
-+ let path, desc = Typetexp.find_class_type env loc lid in
-+ Sig_class_type (id, desc, Trec_not)
-+ in
-+ fprintf ppf "%a@." Printtyp.signature [item]
-+ with
-+ Not_found ->
-+ fprintf ppf "Unknown %s.@." (Printast.string_of_kind kind)
-+ | Failure "invalid" ->
-+ fprintf ppf "Invalid path %a@." Printtyp.longident lid
-+
- let _ =
- Hashtbl.add directive_table "trace" (Directive_ident (dir_trace std_out));
- Hashtbl.add directive_table "untrace" (Directive_ident (dir_untrace std_out));
-@@ -337,4 +402,7 @@
- (Directive_string (parse_warnings std_out false));
-
- Hashtbl.add directive_table "warn_error"
-- (Directive_string (parse_warnings std_out true))
-+ (Directive_string (parse_warnings std_out true));
-+
-+ Hashtbl.add directive_table "show"
-+ (Directive_show (dir_show std_out))
-Index: toplevel/toploop.ml
-===================================================================
---- toplevel/toploop.ml (revision 13955)
-+++ toplevel/toploop.ml (working copy)
-@@ -25,7 +25,8 @@
- | Directive_none of (unit -> unit)
- | Directive_string of (string -> unit)
- | Directive_int of (int -> unit)
-- | Directive_ident of (Longident.t -> unit)
-+ | Directive_ident of (Longident.t Location.loc -> unit)
-+ | Directive_show of (ident_kind -> Longident.t Location.loc -> unit)
- | Directive_bool of (bool -> unit)
-
- (* The table of toplevel value bindings and its accessors *)
-@@ -280,6 +281,7 @@
- | (Directive_string f, Pdir_string s) -> f s; true
- | (Directive_int f, Pdir_int n) -> f n; true
- | (Directive_ident f, Pdir_ident lid) -> f lid; true
-+ | (Directive_show f, Pdir_show (kind,lid)) -> f kind lid; true
- | (Directive_bool f, Pdir_bool b) -> f b; true
- | (_, _) ->
- fprintf ppf "Wrong type of argument for directive `%s'.@." dir_name;
-Index: toplevel/topdirs.mli
-===================================================================
---- toplevel/topdirs.mli (revision 13955)
-+++ toplevel/topdirs.mli (working copy)
-@@ -20,11 +20,12 @@
- val dir_cd : string -> unit
- val dir_load : formatter -> string -> unit
- val dir_use : formatter -> string -> unit
--val dir_install_printer : formatter -> Longident.t -> unit
--val dir_remove_printer : formatter -> Longident.t -> unit
--val dir_trace : formatter -> Longident.t -> unit
--val dir_untrace : formatter -> Longident.t -> unit
-+val dir_install_printer : formatter -> Longident.t Location.loc -> unit
-+val dir_remove_printer : formatter -> Longident.t Location.loc -> unit
-+val dir_trace : formatter -> Longident.t Location.loc -> unit
-+val dir_untrace : formatter -> Longident.t Location.loc -> unit
- val dir_untrace_all : formatter -> unit -> unit
-+val dir_show : formatter -> Parsetree.ident_kind -> Longident.t Location.loc -> unit
-
- type 'a printer_type_new = Format.formatter -> 'a -> unit
- type 'a printer_type_old = 'a -> unit
-Index: toplevel/toploop.mli
-===================================================================
---- toplevel/toploop.mli (revision 13955)
-+++ toplevel/toploop.mli (working copy)
-@@ -37,7 +37,8 @@
- | Directive_none of (unit -> unit)
- | Directive_string of (string -> unit)
- | Directive_int of (int -> unit)
-- | Directive_ident of (Longident.t -> unit)
-+ | Directive_ident of (Longident.t Location.loc -> unit)
-+ | Directive_show of (Parsetree.ident_kind -> Longident.t Location.loc -> unit)
- | Directive_bool of (bool -> unit)
-
- val directive_table : (string, directive_fun) Hashtbl.t
-Index: tools/Makefile.shared
-===================================================================
---- tools/Makefile.shared (revision 13955)
-+++ tools/Makefile.shared (working copy)
-@@ -210,6 +210,7 @@
- ../parsing/location.cmo \
- ../parsing/longident.cmo \
- ../parsing/lexer.cmo \
-+ ../parsing/printast.cmo \
- ../parsing/pprintast.cmo \
- ../typing/ident.cmo \
- ../typing/path.cmo \
-Index: camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
-===================================================================
---- camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml (revision 13955)
-+++ camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml (working copy)
-@@ -1229,7 +1229,7 @@
- | ExInt _ i -> Pdir_int (int_of_string i)
- | <:expr< True >> -> Pdir_bool True
- | <:expr< False >> -> Pdir_bool False
-- | e -> Pdir_ident (ident_noloc (ident_of_expr e)) ]
-+ | e -> Pdir_ident (ident (ident_of_expr e)) ]
- ;
-
- value phrase =
-Index: camlp4/boot/Camlp4.ml
-===================================================================
---- camlp4/boot/Camlp4.ml (revision 13955)
-+++ camlp4/boot/Camlp4.ml (working copy)
-@@ -15686,7 +15686,7 @@
- | ExInt (_, i) -> Pdir_int (int_of_string i)
- | Ast.ExId (_, (Ast.IdUid (_, "True"))) -> Pdir_bool true
- | Ast.ExId (_, (Ast.IdUid (_, "False"))) -> Pdir_bool false
-- | e -> Pdir_ident (ident_noloc (ident_of_expr e))
-+ | e -> Pdir_ident (ident (ident_of_expr e))
-
- let phrase =
- function
+++ /dev/null
-(* $Id$ *)
-
-let f1 = function `a x -> x=1 | `b -> true
-let f2 = function `a x -> x | `b -> true
-let f3 = function `b -> true
-let f x = f1 x && f2 x
-
-let sub s ?:pos{=0} ?:len{=String.length s - pos} () =
- String.sub s pos len
-
-let cCAMLtoTKpack_options w = function
- `After v1 -> "-after"
- | `Anchor v1 -> "-anchor"
- | `Before v1 -> "-before"
- | `Expand v1 -> "-expand"
- | `Fill v1 -> "-fill"
- | `In v1 -> "-in"
- | `Ipadx v1 -> "-ipadx"
- | `Ipady v1 -> "-ipady"
- | `Padx v1 -> "-padx"
- | `Pady v1 -> "-pady"
- | `Side v1 -> "-side"
+++ /dev/null
-Index: utils/warnings.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/utils/warnings.ml,v
-retrieving revision 1.23
-diff -u -r1.23 warnings.ml
---- utils/warnings.ml 15 Sep 2005 03:09:26 -0000 1.23
-+++ utils/warnings.ml 5 Apr 2006 02:25:59 -0000
-@@ -26,7 +26,7 @@
- | Statement_type (* S *)
- | Unused_match (* U *)
- | Unused_pat
-- | Hide_instance_variable of string (* V *)
-+ | Instance_variable_override of string (* V *)
- | Illegal_backslash (* X *)
- | Implicit_public_methods of string list
- | Unerasable_optional_argument
-@@ -54,7 +54,7 @@
- | Statement_type -> 's'
- | Unused_match
- | Unused_pat -> 'u'
-- | Hide_instance_variable _ -> 'v'
-+ | Instance_variable_override _ -> 'v'
- | Illegal_backslash
- | Implicit_public_methods _
- | Unerasable_optional_argument
-@@ -126,9 +126,9 @@
- String.concat " "
- ("the following methods are overridden \
- by the inherited class:\n " :: slist)
-- | Hide_instance_variable lab ->
-- "this definition of an instance variable " ^ lab ^
-- " hides a previously\ndefined instance variable of the same name."
-+ | Instance_variable_override lab ->
-+ "the instance variable " ^ lab ^ " is overridden.\n" ^
-+ "The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)"
- | Partial_application ->
- "this function application is partial,\n\
- maybe some arguments are missing."
-Index: utils/warnings.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/utils/warnings.mli,v
-retrieving revision 1.16
-diff -u -r1.16 warnings.mli
---- utils/warnings.mli 15 Sep 2005 03:09:26 -0000 1.16
-+++ utils/warnings.mli 5 Apr 2006 02:25:59 -0000
-@@ -26,7 +26,7 @@
- | Statement_type (* S *)
- | Unused_match (* U *)
- | Unused_pat
-- | Hide_instance_variable of string (* V *)
-+ | Instance_variable_override of string (* V *)
- | Illegal_backslash (* X *)
- | Implicit_public_methods of string list
- | Unerasable_optional_argument
-Index: parsing/parser.mly
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/parsing/parser.mly,v
-retrieving revision 1.123
-diff -u -r1.123 parser.mly
---- parsing/parser.mly 23 Mar 2005 03:08:37 -0000 1.123
-+++ parsing/parser.mly 5 Apr 2006 02:25:59 -0000
-@@ -623,6 +623,8 @@
- { [] }
- | class_fields INHERIT class_expr parent_binder
- { Pcf_inher ($3, $4) :: $1 }
-+ | class_fields VAL virtual_value
-+ { Pcf_valvirt $3 :: $1 }
- | class_fields VAL value
- { Pcf_val $3 :: $1 }
- | class_fields virtual_method
-@@ -638,14 +640,20 @@
- AS LIDENT
- { Some $2 }
- | /* empty */
-- {None}
-+ { None }
-+;
-+virtual_value:
-+ MUTABLE VIRTUAL label COLON core_type
-+ { $3, Mutable, $5, symbol_rloc () }
-+ | VIRTUAL mutable_flag label COLON core_type
-+ { $3, $2, $5, symbol_rloc () }
- ;
- value:
-- mutable_flag label EQUAL seq_expr
-- { $2, $1, $4, symbol_rloc () }
-- | mutable_flag label type_constraint EQUAL seq_expr
-- { $2, $1, (let (t, t') = $3 in ghexp(Pexp_constraint($5, t, t'))),
-- symbol_rloc () }
-+ mutable_flag label EQUAL seq_expr
-+ { $2, $1, $4, symbol_rloc () }
-+ | mutable_flag label type_constraint EQUAL seq_expr
-+ { $2, $1, (let (t, t') = $3 in ghexp(Pexp_constraint($5, t, t'))),
-+ symbol_rloc () }
- ;
- virtual_method:
- METHOD PRIVATE VIRTUAL label COLON poly_type
-@@ -711,8 +719,12 @@
- | class_sig_fields CONSTRAINT constrain { Pctf_cstr $3 :: $1 }
- ;
- value_type:
-- mutable_flag label COLON core_type
-- { $2, $1, Some $4, symbol_rloc () }
-+ VIRTUAL mutable_flag label COLON core_type
-+ { $3, $2, Virtual, $5, symbol_rloc () }
-+ | MUTABLE virtual_flag label COLON core_type
-+ { $3, Mutable, $2, $5, symbol_rloc () }
-+ | label COLON core_type
-+ { $1, Immutable, Concrete, $3, symbol_rloc () }
- ;
- method_type:
- METHOD private_flag label COLON poly_type
-Index: parsing/parsetree.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/parsing/parsetree.mli,v
-retrieving revision 1.42
-diff -u -r1.42 parsetree.mli
---- parsing/parsetree.mli 23 Mar 2005 03:08:37 -0000 1.42
-+++ parsing/parsetree.mli 5 Apr 2006 02:25:59 -0000
-@@ -152,7 +152,7 @@
-
- and class_type_field =
- Pctf_inher of class_type
-- | Pctf_val of (string * mutable_flag * core_type option * Location.t)
-+ | Pctf_val of (string * mutable_flag * virtual_flag * core_type * Location.t)
- | Pctf_virt of (string * private_flag * core_type * Location.t)
- | Pctf_meth of (string * private_flag * core_type * Location.t)
- | Pctf_cstr of (core_type * core_type * Location.t)
-@@ -179,6 +179,7 @@
-
- and class_field =
- Pcf_inher of class_expr * string option
-+ | Pcf_valvirt of (string * mutable_flag * core_type * Location.t)
- | Pcf_val of (string * mutable_flag * expression * Location.t)
- | Pcf_virt of (string * private_flag * core_type * Location.t)
- | Pcf_meth of (string * private_flag * expression * Location.t)
-Index: parsing/printast.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/parsing/printast.ml,v
-retrieving revision 1.29
-diff -u -r1.29 printast.ml
---- parsing/printast.ml 4 Jan 2006 16:55:50 -0000 1.29
-+++ parsing/printast.ml 5 Apr 2006 02:25:59 -0000
-@@ -353,10 +353,11 @@
- | Pctf_inher (ct) ->
- line i ppf "Pctf_inher\n";
- class_type i ppf ct;
-- | Pctf_val (s, mf, cto, loc) ->
-+ | Pctf_val (s, mf, vf, ct, loc) ->
- line i ppf
-- "Pctf_val \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc;
-- option i core_type ppf cto;
-+ "Pctf_val \"%s\" %a %a %a\n" s
-+ fmt_mutable_flag mf fmt_virtual_flag vf fmt_location loc;
-+ core_type (i+1) ppf ct;
- | Pctf_virt (s, pf, ct, loc) ->
- line i ppf
- "Pctf_virt \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc;
-@@ -428,6 +429,10 @@
- line i ppf "Pcf_inher\n";
- class_expr (i+1) ppf ce;
- option (i+1) string ppf so;
-+ | Pcf_valvirt (s, mf, ct, loc) ->
-+ line i ppf
-+ "Pcf_valvirt \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc;
-+ core_type (i+1) ppf ct;
- | Pcf_val (s, mf, e, loc) ->
- line i ppf
- "Pcf_val \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc;
-Index: typing/btype.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/btype.ml,v
-retrieving revision 1.38
-diff -u -r1.38 btype.ml
---- typing/btype.ml 4 Jan 2006 16:55:50 -0000 1.38
-+++ typing/btype.ml 5 Apr 2006 02:25:59 -0000
-@@ -330,7 +330,7 @@
-
- let unmark_class_signature sign =
- unmark_type sign.cty_self;
-- Vars.iter (fun l (m, t) -> unmark_type t) sign.cty_vars
-+ Vars.iter (fun l (m, v, t) -> unmark_type t) sign.cty_vars
-
- let rec unmark_class_type =
- function
-Index: typing/ctype.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v
-retrieving revision 1.200
-diff -u -r1.200 ctype.ml
---- typing/ctype.ml 6 Jan 2006 02:16:24 -0000 1.200
-+++ typing/ctype.ml 5 Apr 2006 02:25:59 -0000
-@@ -857,7 +857,7 @@
- Tcty_signature
- {cty_self = copy sign.cty_self;
- cty_vars =
-- Vars.map (function (mut, ty) -> (mut, copy ty)) sign.cty_vars;
-+ Vars.map (function (m, v, ty) -> (m, v, copy ty)) sign.cty_vars;
- cty_concr = sign.cty_concr;
- cty_inher =
- List.map (fun (p,tl) -> (p, List.map copy tl)) sign.cty_inher}
-@@ -2354,10 +2354,11 @@
- | CM_Val_type_mismatch of string * (type_expr * type_expr) list
- | CM_Meth_type_mismatch of string * (type_expr * type_expr) list
- | CM_Non_mutable_value of string
-+ | CM_Non_concrete_value of string
- | CM_Missing_value of string
- | CM_Missing_method of string
- | CM_Hide_public of string
-- | CM_Hide_virtual of string
-+ | CM_Hide_virtual of string * string
- | CM_Public_method of string
- | CM_Private_method of string
- | CM_Virtual_method of string
-@@ -2390,8 +2391,8 @@
- end)
- pairs;
- Vars.iter
-- (fun lab (mut, ty) ->
-- let (mut', ty') = Vars.find lab sign1.cty_vars in
-+ (fun lab (mut, v, ty) ->
-+ let (mut', v', ty') = Vars.find lab sign1.cty_vars in
- try moregen true type_pairs env ty' ty with Unify trace ->
- raise (Failure [CM_Val_type_mismatch
- (lab, expand_trace env trace)]))
-@@ -2437,7 +2438,7 @@
- end
- in
- if Concr.mem lab sign1.cty_concr then err
-- else CM_Hide_virtual lab::err)
-+ else CM_Hide_virtual ("method", lab) :: err)
- miss1 []
- in
- let missing_method = List.map (fun (m, _, _) -> m) miss2 in
-@@ -2455,11 +2456,13 @@
- in
- let error =
- Vars.fold
-- (fun lab (mut, ty) err ->
-+ (fun lab (mut, vr, ty) err ->
- try
-- let (mut', ty') = Vars.find lab sign1.cty_vars in
-+ let (mut', vr', ty') = Vars.find lab sign1.cty_vars in
- if mut = Mutable && mut' <> Mutable then
- CM_Non_mutable_value lab::err
-+ else if vr = Concrete && vr' <> Concrete then
-+ CM_Non_concrete_value lab::err
- else
- err
- with Not_found ->
-@@ -2467,6 +2470,14 @@
- sign2.cty_vars error
- in
- let error =
-+ Vars.fold
-+ (fun lab (_,vr,_) err ->
-+ if vr = Virtual && not (Vars.mem lab sign2.cty_vars) then
-+ CM_Hide_virtual ("instance variable", lab) :: err
-+ else err)
-+ sign1.cty_vars error
-+ in
-+ let error =
- List.fold_right
- (fun e l ->
- if List.mem e missing_method then l else CM_Virtual_method e::l)
-@@ -2516,8 +2527,8 @@
- end)
- pairs;
- Vars.iter
-- (fun lab (mut, ty) ->
-- let (mut', ty') = Vars.find lab sign1.cty_vars in
-+ (fun lab (_, _, ty) ->
-+ let (_, _, ty') = Vars.find lab sign1.cty_vars in
- try eqtype true type_pairs subst env ty ty' with Unify trace ->
- raise (Failure [CM_Val_type_mismatch
- (lab, expand_trace env trace)]))
-@@ -2554,7 +2565,7 @@
- end
- in
- if Concr.mem lab sign1.cty_concr then err
-- else CM_Hide_virtual lab::err)
-+ else CM_Hide_virtual ("method", lab) :: err)
- miss1 []
- in
- let missing_method = List.map (fun (m, _, _) -> m) miss2 in
-@@ -2578,11 +2589,13 @@
- in
- let error =
- Vars.fold
-- (fun lab (mut, ty) err ->
-+ (fun lab (mut, vr, ty) err ->
- try
-- let (mut', ty') = Vars.find lab sign1.cty_vars in
-+ let (mut', vr', ty') = Vars.find lab sign1.cty_vars in
- if mut = Mutable && mut' <> Mutable then
- CM_Non_mutable_value lab::err
-+ else if vr = Concrete && vr' <> Concrete then
-+ CM_Non_concrete_value lab::err
- else
- err
- with Not_found ->
-@@ -2590,6 +2603,14 @@
- sign2.cty_vars error
- in
- let error =
-+ Vars.fold
-+ (fun lab (_,vr,_) err ->
-+ if vr = Virtual && not (Vars.mem lab sign2.cty_vars) then
-+ CM_Hide_virtual ("instance variable", lab) :: err
-+ else err)
-+ sign1.cty_vars error
-+ in
-+ let error =
- List.fold_right
- (fun e l ->
- if List.mem e missing_method then l else CM_Virtual_method e::l)
-@@ -3279,7 +3300,7 @@
- let nondep_class_signature env id sign =
- { cty_self = nondep_type_rec env id sign.cty_self;
- cty_vars =
-- Vars.map (function (m, t) -> (m, nondep_type_rec env id t))
-+ Vars.map (function (m, v, t) -> (m, v, nondep_type_rec env id t))
- sign.cty_vars;
- cty_concr = sign.cty_concr;
- cty_inher =
-Index: typing/ctype.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.mli,v
-retrieving revision 1.53
-diff -u -r1.53 ctype.mli
---- typing/ctype.mli 9 Dec 2004 12:40:53 -0000 1.53
-+++ typing/ctype.mli 5 Apr 2006 02:25:59 -0000
-@@ -170,10 +170,11 @@
- | CM_Val_type_mismatch of string * (type_expr * type_expr) list
- | CM_Meth_type_mismatch of string * (type_expr * type_expr) list
- | CM_Non_mutable_value of string
-+ | CM_Non_concrete_value of string
- | CM_Missing_value of string
- | CM_Missing_method of string
- | CM_Hide_public of string
-- | CM_Hide_virtual of string
-+ | CM_Hide_virtual of string * string
- | CM_Public_method of string
- | CM_Private_method of string
- | CM_Virtual_method of string
-Index: typing/includeclass.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/includeclass.ml,v
-retrieving revision 1.7
-diff -u -r1.7 includeclass.ml
---- typing/includeclass.ml 6 Mar 2000 22:11:57 -0000 1.7
-+++ typing/includeclass.ml 5 Apr 2006 02:25:59 -0000
-@@ -78,14 +78,17 @@
- | CM_Non_mutable_value lab ->
- fprintf ppf
- "@[The non-mutable instance variable %s cannot become mutable@]" lab
-+ | CM_Non_concrete_value lab ->
-+ fprintf ppf
-+ "@[The virtual instance variable %s cannot become concrete@]" lab
- | CM_Missing_value lab ->
- fprintf ppf "@[The first class type has no instance variable %s@]" lab
- | CM_Missing_method lab ->
- fprintf ppf "@[The first class type has no method %s@]" lab
- | CM_Hide_public lab ->
- fprintf ppf "@[The public method %s cannot be hidden@]" lab
-- | CM_Hide_virtual lab ->
-- fprintf ppf "@[The virtual method %s cannot be hidden@]" lab
-+ | CM_Hide_virtual (k, lab) ->
-+ fprintf ppf "@[The virtual %s %s cannot be hidden@]" k lab
- | CM_Public_method lab ->
- fprintf ppf "@[The public method %s cannot become private" lab
- | CM_Virtual_method lab ->
-Index: typing/oprint.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/oprint.ml,v
-retrieving revision 1.22
-diff -u -r1.22 oprint.ml
---- typing/oprint.ml 23 Mar 2005 03:08:37 -0000 1.22
-+++ typing/oprint.ml 5 Apr 2006 02:25:59 -0000
-@@ -291,8 +291,10 @@
- fprintf ppf "@[<2>method %s%s%s :@ %a@]"
- (if priv then "private " else "") (if virt then "virtual " else "")
- name !out_type ty
-- | Ocsg_value (name, mut, ty) ->
-- fprintf ppf "@[<2>val %s%s :@ %a@]" (if mut then "mutable " else "")
-+ | Ocsg_value (name, mut, vr, ty) ->
-+ fprintf ppf "@[<2>val %s%s%s :@ %a@]"
-+ (if mut then "mutable " else "")
-+ (if vr then "virtual " else "")
- name !out_type ty
-
- let out_class_type = ref print_out_class_type
-Index: typing/outcometree.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/outcometree.mli,v
-retrieving revision 1.14
-diff -u -r1.14 outcometree.mli
---- typing/outcometree.mli 23 Mar 2005 03:08:37 -0000 1.14
-+++ typing/outcometree.mli 5 Apr 2006 02:25:59 -0000
-@@ -71,7 +71,7 @@
- and out_class_sig_item =
- | Ocsg_constraint of out_type * out_type
- | Ocsg_method of string * bool * bool * out_type
-- | Ocsg_value of string * bool * out_type
-+ | Ocsg_value of string * bool * bool * out_type
-
- type out_module_type =
- | Omty_abstract
-Index: typing/printtyp.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/printtyp.ml,v
-retrieving revision 1.140
-diff -u -r1.140 printtyp.ml
---- typing/printtyp.ml 4 Jan 2006 16:55:50 -0000 1.140
-+++ typing/printtyp.ml 5 Apr 2006 02:26:00 -0000
-@@ -650,7 +650,7 @@
- Ctype.flatten_fields (Ctype.object_fields sign.cty_self)
- in
- List.iter (fun met -> mark_loops (method_type met)) fields;
-- Vars.iter (fun _ (_, ty) -> mark_loops ty) sign.cty_vars
-+ Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.cty_vars
- | Tcty_fun (_, ty, cty) ->
- mark_loops ty;
- prepare_class_type params cty
-@@ -682,13 +682,15 @@
- csil (tree_of_constraints params)
- in
- let all_vars =
-- Vars.fold (fun l (m, t) all -> (l, m, t) :: all) sign.cty_vars [] in
-+ Vars.fold (fun l (m, v, t) all -> (l, m, v, t) :: all) sign.cty_vars []
-+ in
- (* Consequence of PR#3607: order of Map.fold has changed! *)
- let all_vars = List.rev all_vars in
- let csil =
- List.fold_left
-- (fun csil (l, m, t) ->
-- Ocsg_value (l, m = Mutable, tree_of_typexp sch t) :: csil)
-+ (fun csil (l, m, v, t) ->
-+ Ocsg_value (l, m = Mutable, v = Virtual, tree_of_typexp sch t)
-+ :: csil)
- csil all_vars
- in
- let csil =
-@@ -763,7 +765,9 @@
- List.exists
- (fun (lab, _, ty) ->
- not (lab = dummy_method || Concr.mem lab sign.cty_concr))
-- fields in
-+ fields
-+ || Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) sign.cty_vars false
-+ in
-
- Osig_class_type
- (virt, Ident.name id,
-Index: typing/subst.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/subst.ml,v
-retrieving revision 1.49
-diff -u -r1.49 subst.ml
---- typing/subst.ml 4 Jan 2006 16:55:50 -0000 1.49
-+++ typing/subst.ml 5 Apr 2006 02:26:00 -0000
-@@ -178,7 +178,8 @@
-
- let class_signature s sign =
- { cty_self = typexp s sign.cty_self;
-- cty_vars = Vars.map (function (m, t) -> (m, typexp s t)) sign.cty_vars;
-+ cty_vars =
-+ Vars.map (function (m, v, t) -> (m, v, typexp s t)) sign.cty_vars;
- cty_concr = sign.cty_concr;
- cty_inher =
- List.map (fun (p, tl) -> (type_path s p, List.map (typexp s) tl))
-Index: typing/typeclass.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typeclass.ml,v
-retrieving revision 1.85
-diff -u -r1.85 typeclass.ml
---- typing/typeclass.ml 22 Jul 2005 06:42:36 -0000 1.85
-+++ typing/typeclass.ml 5 Apr 2006 02:26:00 -0000
-@@ -24,7 +24,7 @@
-
- type error =
- Unconsistent_constraint of (type_expr * type_expr) list
-- | Method_type_mismatch of string * (type_expr * type_expr) list
-+ | Field_type_mismatch of string * string * (type_expr * type_expr) list
- | Structure_expected of class_type
- | Cannot_apply of class_type
- | Apply_wrong_label of label
-@@ -36,7 +36,7 @@
- | Unbound_class_type_2 of Longident.t
- | Abbrev_type_clash of type_expr * type_expr * type_expr
- | Constructor_type_mismatch of string * (type_expr * type_expr) list
-- | Virtual_class of bool * string list
-+ | Virtual_class of bool * string list * string list
- | Parameter_arity_mismatch of Longident.t * int * int
- | Parameter_mismatch of (type_expr * type_expr) list
- | Bad_parameters of Ident.t * type_expr * type_expr
-@@ -49,6 +49,7 @@
- | Non_collapsable_conjunction of
- Ident.t * Types.class_declaration * (type_expr * type_expr) list
- | Final_self_clash of (type_expr * type_expr) list
-+ | Mutability_mismatch of string * mutable_flag
-
- exception Error of Location.t * error
-
-@@ -90,7 +91,7 @@
- generalize_class_type cty
- | Tcty_signature {cty_self = sty; cty_vars = vars; cty_inher = inher} ->
- Ctype.generalize sty;
-- Vars.iter (fun _ (_, ty) -> Ctype.generalize ty) vars;
-+ Vars.iter (fun _ (_, _, ty) -> Ctype.generalize ty) vars;
- List.iter (fun (_,tl) -> List.iter Ctype.generalize tl) inher
- | Tcty_fun (_, ty, cty) ->
- Ctype.generalize ty;
-@@ -152,7 +153,7 @@
- | Tcty_signature sign ->
- Ctype.closed_schema sign.cty_self
- &&
-- Vars.fold (fun _ (_, ty) cc -> Ctype.closed_schema ty && cc)
-+ Vars.fold (fun _ (_, _, ty) cc -> Ctype.closed_schema ty && cc)
- sign.cty_vars
- true
- | Tcty_fun (_, ty, cty) ->
-@@ -172,7 +173,7 @@
- limited_generalize rv cty
- | Tcty_signature sign ->
- Ctype.limited_generalize rv sign.cty_self;
-- Vars.iter (fun _ (_, ty) -> Ctype.limited_generalize rv ty)
-+ Vars.iter (fun _ (_, _, ty) -> Ctype.limited_generalize rv ty)
- sign.cty_vars;
- List.iter (fun (_, tl) -> List.iter (Ctype.limited_generalize rv) tl)
- sign.cty_inher
-@@ -201,11 +202,25 @@
- Env.add_value id {val_type = ty; val_kind = Val_unbound} par_env)
-
- (* Enter an instance variable in the environment *)
--let enter_val cl_num vars lab mut ty val_env met_env par_env =
-- let (id, val_env, met_env, par_env) as result =
-- enter_met_env lab (Val_ivar (mut, cl_num)) ty val_env met_env par_env
-+let enter_val cl_num vars inh lab mut virt ty val_env met_env par_env loc =
-+ let (id, virt) =
-+ try
-+ let (id, mut', virt', ty') = Vars.find lab !vars in
-+ if mut' <> mut then raise (Error(loc, Mutability_mismatch(lab, mut)));
-+ Ctype.unify val_env (Ctype.instance ty) (Ctype.instance ty');
-+ (if not inh then Some id else None),
-+ (if virt' = Concrete then virt' else virt)
-+ with
-+ Ctype.Unify tr ->
-+ raise (Error(loc, Field_type_mismatch("instance variable", lab, tr)))
-+ | Not_found -> None, virt
-+ in
-+ let (id, _, _, _) as result =
-+ match id with Some id -> (id, val_env, met_env, par_env)
-+ | None ->
-+ enter_met_env lab (Val_ivar (mut, cl_num)) ty val_env met_env par_env
- in
-- vars := Vars.add lab (id, mut, ty) !vars;
-+ vars := Vars.add lab (id, mut, virt, ty) !vars;
- result
-
- let inheritance self_type env concr_meths warn_meths loc parent =
-@@ -218,7 +233,7 @@
- with Ctype.Unify trace ->
- match trace with
- _::_::_::({desc = Tfield(n, _, _, _)}, _)::rem ->
-- raise(Error(loc, Method_type_mismatch (n, rem)))
-+ raise(Error(loc, Field_type_mismatch ("method", n, rem)))
- | _ ->
- assert false
- end;
-@@ -243,7 +258,7 @@
- in
- let ty = transl_simple_type val_env false sty in
- try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
-- raise(Error(loc, Method_type_mismatch (lab, trace)))
-+ raise(Error(loc, Field_type_mismatch ("method", lab, trace)))
-
- let delayed_meth_specs = ref []
-
-@@ -253,7 +268,7 @@
- in
- let unif ty =
- try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
-- raise(Error(loc, Method_type_mismatch (lab, trace)))
-+ raise(Error(loc, Field_type_mismatch ("method", lab, trace)))
- in
- match sty.ptyp_desc, priv with
- Ptyp_poly ([],sty), Public ->
-@@ -279,6 +294,15 @@
-
- (*******************************)
-
-+let add_val env loc lab (mut, virt, ty) val_sig =
-+ let virt =
-+ try
-+ let (mut', virt', ty') = Vars.find lab val_sig in
-+ if virt' = Concrete then virt' else virt
-+ with Not_found -> virt
-+ in
-+ Vars.add lab (mut, virt, ty) val_sig
-+
- let rec class_type_field env self_type meths (val_sig, concr_meths, inher) =
- function
- Pctf_inher sparent ->
-@@ -293,25 +317,12 @@
- parent
- in
- let val_sig =
-- Vars.fold
-- (fun lab (mut, ty) val_sig -> Vars.add lab (mut, ty) val_sig)
-- cl_sig.cty_vars val_sig
-- in
-+ Vars.fold (add_val env sparent.pcty_loc) cl_sig.cty_vars val_sig in
- (val_sig, concr_meths, inher)
-
-- | Pctf_val (lab, mut, sty_opt, loc) ->
-- let (mut, ty) =
-- match sty_opt with
-- None ->
-- let (mut', ty) =
-- try Vars.find lab val_sig with Not_found ->
-- raise(Error(loc, Unbound_val lab))
-- in
-- (if mut = Mutable then mut' else Immutable), ty
-- | Some sty ->
-- mut, transl_simple_type env false sty
-- in
-- (Vars.add lab (mut, ty) val_sig, concr_meths, inher)
-+ | Pctf_val (lab, mut, virt, sty, loc) ->
-+ let ty = transl_simple_type env false sty in
-+ (add_val env loc lab (mut, virt, ty) val_sig, concr_meths, inher)
-
- | Pctf_virt (lab, priv, sty, loc) ->
- declare_method env meths self_type lab priv sty loc;
-@@ -397,7 +408,7 @@
-
- let rec class_field cl_num self_type meths vars
- (val_env, met_env, par_env, fields, concr_meths, warn_meths,
-- inh_vals, inher) =
-+ warn_vals, inher) =
- function
- Pcf_inher (sparent, super) ->
- let parent = class_expr cl_num val_env par_env sparent in
-@@ -411,18 +422,23 @@
- parent.cl_type
- in
- (* Variables *)
-- let (val_env, met_env, par_env, inh_vars, inh_vals) =
-+ let (val_env, met_env, par_env, inh_vars, warn_vals) =
- Vars.fold
-- (fun lab (mut, ty) (val_env, met_env, par_env, inh_vars, inh_vals) ->
-+ (fun lab info (val_env, met_env, par_env, inh_vars, warn_vals) ->
-+ let mut, vr, ty = info in
- let (id, val_env, met_env, par_env) =
-- enter_val cl_num vars lab mut ty val_env met_env par_env
-+ enter_val cl_num vars true lab mut vr ty val_env met_env par_env
-+ sparent.pcl_loc
- in
-- if StringSet.mem lab inh_vals then
-- Location.prerr_warning sparent.pcl_loc
-- (Warnings.Hide_instance_variable lab);
-- (val_env, met_env, par_env, (lab, id) :: inh_vars,
-- StringSet.add lab inh_vals))
-- cl_sig.cty_vars (val_env, met_env, par_env, [], inh_vals)
-+ let warn_vals =
-+ if vr = Virtual then warn_vals else
-+ if StringSet.mem lab warn_vals then
-+ (Location.prerr_warning sparent.pcl_loc
-+ (Warnings.Instance_variable_override lab); warn_vals)
-+ else StringSet.add lab warn_vals
-+ in
-+ (val_env, met_env, par_env, (lab, id) :: inh_vars, warn_vals))
-+ cl_sig.cty_vars (val_env, met_env, par_env, [], warn_vals)
- in
- (* Inherited concrete methods *)
- let inh_meths =
-@@ -443,11 +459,26 @@
- in
- (val_env, met_env, par_env,
- lazy(Cf_inher (parent, inh_vars, inh_meths))::fields,
-- concr_meths, warn_meths, inh_vals, inher)
-+ concr_meths, warn_meths, warn_vals, inher)
-+
-+ | Pcf_valvirt (lab, mut, styp, loc) ->
-+ if !Clflags.principal then Ctype.begin_def ();
-+ let ty = Typetexp.transl_simple_type val_env false styp in
-+ if !Clflags.principal then begin
-+ Ctype.end_def ();
-+ Ctype.generalize_structure ty
-+ end;
-+ let (id, val_env, met_env', par_env) =
-+ enter_val cl_num vars false lab mut Virtual ty
-+ val_env met_env par_env loc
-+ in
-+ (val_env, met_env', par_env,
-+ lazy(Cf_val (lab, id, None, met_env' == met_env)) :: fields,
-+ concr_meths, warn_meths, StringSet.remove lab warn_vals, inher)
-
- | Pcf_val (lab, mut, sexp, loc) ->
-- if StringSet.mem lab inh_vals then
-- Location.prerr_warning loc (Warnings.Hide_instance_variable lab);
-+ if StringSet.mem lab warn_vals then
-+ Location.prerr_warning loc (Warnings.Instance_variable_override lab);
- if !Clflags.principal then Ctype.begin_def ();
- let exp =
- try type_exp val_env sexp with Ctype.Unify [(ty, _)] ->
-@@ -457,17 +488,19 @@
- Ctype.end_def ();
- Ctype.generalize_structure exp.exp_type
- end;
-- let (id, val_env, met_env, par_env) =
-- enter_val cl_num vars lab mut exp.exp_type val_env met_env par_env
-- in
-- (val_env, met_env, par_env, lazy(Cf_val (lab, id, exp)) :: fields,
-- concr_meths, warn_meths, inh_vals, inher)
-+ let (id, val_env, met_env', par_env) =
-+ enter_val cl_num vars false lab mut Concrete exp.exp_type
-+ val_env met_env par_env loc
-+ in
-+ (val_env, met_env', par_env,
-+ lazy(Cf_val (lab, id, Some exp, met_env' == met_env)) :: fields,
-+ concr_meths, warn_meths, StringSet.add lab warn_vals, inher)
-
- | Pcf_virt (lab, priv, sty, loc) ->
- virtual_method val_env meths self_type lab priv sty loc;
- let warn_meths = Concr.remove lab warn_meths in
- (val_env, met_env, par_env, fields, concr_meths, warn_meths,
-- inh_vals, inher)
-+ warn_vals, inher)
-
- | Pcf_meth (lab, priv, expr, loc) ->
- let (_, ty) =
-@@ -493,7 +526,7 @@
- end
- | _ -> assert false
- with Ctype.Unify trace ->
-- raise(Error(loc, Method_type_mismatch (lab, trace)))
-+ raise(Error(loc, Field_type_mismatch ("method", lab, trace)))
- end;
- let meth_expr = make_method cl_num expr in
- (* backup variables for Pexp_override *)
-@@ -510,12 +543,12 @@
- Cf_meth (lab, texp)
- end in
- (val_env, met_env, par_env, field::fields,
-- Concr.add lab concr_meths, Concr.add lab warn_meths, inh_vals, inher)
-+ Concr.add lab concr_meths, Concr.add lab warn_meths, warn_vals, inher)
-
- | Pcf_cstr (sty, sty', loc) ->
- type_constraint val_env sty sty' loc;
- (val_env, met_env, par_env, fields, concr_meths, warn_meths,
-- inh_vals, inher)
-+ warn_vals, inher)
-
- | Pcf_let (rec_flag, sdefs, loc) ->
- let (defs, val_env) =
-@@ -545,7 +578,7 @@
- ([], met_env, par_env)
- in
- (val_env, met_env, par_env, lazy(Cf_let(rec_flag, defs, vals))::fields,
-- concr_meths, warn_meths, inh_vals, inher)
-+ concr_meths, warn_meths, warn_vals, inher)
-
- | Pcf_init expr ->
- let expr = make_method cl_num expr in
-@@ -562,7 +595,7 @@
- Cf_init texp
- end in
- (val_env, met_env, par_env, field::fields,
-- concr_meths, warn_meths, inh_vals, inher)
-+ concr_meths, warn_meths, warn_vals, inher)
-
- and class_structure cl_num final val_env met_env loc (spat, str) =
- (* Environment for substructures *)
-@@ -616,7 +649,7 @@
- Ctype.unify val_env self_type (Ctype.newvar ());
- let sign =
- {cty_self = public_self;
-- cty_vars = Vars.map (function (id, mut, ty) -> (mut, ty)) !vars;
-+ cty_vars = Vars.map (fun (id, mut, vr, ty) -> (mut, vr, ty)) !vars;
- cty_concr = concr_meths;
- cty_inher = inher} in
- let methods = get_methods self_type in
-@@ -628,7 +661,11 @@
- be modified after this point *)
- Ctype.close_object self_type;
- let mets = virtual_methods {sign with cty_self = self_type} in
-- if mets <> [] then raise(Error(loc, Virtual_class(true, mets)));
-+ let vals =
-+ Vars.fold
-+ (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l)
-+ sign.cty_vars [] in
-+ if mets <> [] then raise(Error(loc, Virtual_class(true, mets, vals)));
- let self_methods =
- List.fold_right
- (fun (lab,kind,ty) rem ->
-@@ -1135,9 +1172,14 @@
- in
-
- if cl.pci_virt = Concrete then begin
-- match virtual_methods (Ctype.signature_of_class_type typ) with
-- [] -> ()
-- | mets -> raise(Error(cl.pci_loc, Virtual_class(define_class, mets)))
-+ let sign = Ctype.signature_of_class_type typ in
-+ let mets = virtual_methods sign in
-+ let vals =
-+ Vars.fold
-+ (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l)
-+ sign.cty_vars [] in
-+ if mets <> [] || vals <> [] then
-+ raise(Error(cl.pci_loc, Virtual_class(true, mets, vals)));
- end;
-
- (* Misc. *)
-@@ -1400,10 +1442,10 @@
- Printtyp.report_unification_error ppf trace
- (fun ppf -> fprintf ppf "Type")
- (fun ppf -> fprintf ppf "is not compatible with type")
-- | Method_type_mismatch (m, trace) ->
-+ | Field_type_mismatch (k, m, trace) ->
- Printtyp.report_unification_error ppf trace
- (function ppf ->
-- fprintf ppf "The method %s@ has type" m)
-+ fprintf ppf "The %s %s@ has type" k m)
- (function ppf ->
- fprintf ppf "but is expected to have type")
- | Structure_expected clty ->
-@@ -1451,15 +1493,20 @@
- fprintf ppf "The expression \"new %s\" has type" c)
- (function ppf ->
- fprintf ppf "but is used with type")
-- | Virtual_class (cl, mets) ->
-+ | Virtual_class (cl, mets, vals) ->
- let print_mets ppf mets =
- List.iter (function met -> fprintf ppf "@ %s" met) mets in
- let cl_mark = if cl then "" else " type" in
-+ let missings =
-+ match mets, vals with
-+ [], _ -> "variables"
-+ | _, [] -> "methods"
-+ | _ -> "methods and variables"
-+ in
- fprintf ppf
-- "@[This class%s should be virtual@ \
-- @[<2>The following methods are undefined :%a@]
-- @]"
-- cl_mark print_mets mets
-+ "@[This class%s should be virtual.@ \
-+ @[<2>The following %s are undefined :%a@]@]"
-+ cl_mark missings print_mets (mets @ vals)
- | Parameter_arity_mismatch(lid, expected, provided) ->
- fprintf ppf
- "@[The class constructor %a@ expects %i type argument(s),@ \
-@@ -1532,3 +1579,10 @@
- fprintf ppf "This object is expected to have type")
- (function ppf ->
- fprintf ppf "but has actually type")
-+ | Mutability_mismatch (lab, mut) ->
-+ let mut1, mut2 =
-+ if mut = Immutable then "mutable", "immutable"
-+ else "immutable", "mutable" in
-+ fprintf ppf
-+ "@[The instance variable is %s,@ it cannot be redefined as %s@]"
-+ mut1 mut2
-Index: typing/typeclass.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typeclass.mli,v
-retrieving revision 1.18
-diff -u -r1.18 typeclass.mli
---- typing/typeclass.mli 1 Dec 2003 00:32:11 -0000 1.18
-+++ typing/typeclass.mli 5 Apr 2006 02:26:00 -0000
-@@ -49,7 +49,7 @@
-
- type error =
- Unconsistent_constraint of (type_expr * type_expr) list
-- | Method_type_mismatch of string * (type_expr * type_expr) list
-+ | Field_type_mismatch of string * string * (type_expr * type_expr) list
- | Structure_expected of class_type
- | Cannot_apply of class_type
- | Apply_wrong_label of label
-@@ -61,7 +61,7 @@
- | Unbound_class_type_2 of Longident.t
- | Abbrev_type_clash of type_expr * type_expr * type_expr
- | Constructor_type_mismatch of string * (type_expr * type_expr) list
-- | Virtual_class of bool * string list
-+ | Virtual_class of bool * string list * string list
- | Parameter_arity_mismatch of Longident.t * int * int
- | Parameter_mismatch of (type_expr * type_expr) list
- | Bad_parameters of Ident.t * type_expr * type_expr
-@@ -74,6 +74,7 @@
- | Non_collapsable_conjunction of
- Ident.t * Types.class_declaration * (type_expr * type_expr) list
- | Final_self_clash of (type_expr * type_expr) list
-+ | Mutability_mismatch of string * mutable_flag
-
- exception Error of Location.t * error
-
-Index: typing/typecore.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v
-retrieving revision 1.178
-diff -u -r1.178 typecore.ml
---- typing/typecore.ml 6 Jan 2006 02:25:37 -0000 1.178
-+++ typing/typecore.ml 5 Apr 2006 02:26:00 -0000
-@@ -611,11 +611,11 @@
- List.for_all
- (function
- Cf_meth _ -> true
-- | Cf_val (_,_,e) -> incr count; is_nonexpansive e
-+ | Cf_val (_,_,e,_) -> incr count; is_nonexpansive_opt e
- | Cf_init e -> is_nonexpansive e
- | Cf_inher _ | Cf_let _ -> false)
- fields &&
-- Vars.fold (fun _ (mut,_) b -> decr count; b && mut = Immutable)
-+ Vars.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable)
- vars true &&
- !count = 0
- | _ -> false
-@@ -1356,7 +1356,7 @@
- (path_self, _) ->
- let type_override (lab, snewval) =
- begin try
-- let (id, _, ty) = Vars.find lab !vars in
-+ let (id, _, _, ty) = Vars.find lab !vars in
- (Path.Pident id, type_expect env snewval (instance ty))
- with
- Not_found ->
-Index: typing/typecore.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.mli,v
-retrieving revision 1.37
-diff -u -r1.37 typecore.mli
---- typing/typecore.mli 4 Mar 2005 14:51:31 -0000 1.37
-+++ typing/typecore.mli 5 Apr 2006 02:26:00 -0000
-@@ -38,7 +38,8 @@
- string -> type_expr -> Env.t -> Env.t -> Env.t -> Parsetree.pattern ->
- Typedtree.pattern *
- (Ident.t * type_expr) Meths.t ref *
-- (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
-+ (Ident.t * Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr)
-+ Vars.t ref *
- Env.t * Env.t * Env.t
- val type_expect:
- ?in_function:(Location.t * type_expr) ->
-Index: typing/typedtree.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typedtree.ml,v
-retrieving revision 1.36
-diff -u -r1.36 typedtree.ml
---- typing/typedtree.ml 25 Nov 2003 09:20:43 -0000 1.36
-+++ typing/typedtree.ml 5 Apr 2006 02:26:00 -0000
-@@ -106,7 +106,7 @@
-
- and class_field =
- Cf_inher of class_expr * (string * Ident.t) list * (string * Ident.t) list
-- | Cf_val of string * Ident.t * expression
-+ | Cf_val of string * Ident.t * expression option * bool
- | Cf_meth of string * expression
- | Cf_let of rec_flag * (pattern * expression) list *
- (Ident.t * expression) list
-@@ -140,7 +140,8 @@
- | Tstr_recmodule of (Ident.t * module_expr) list
- | Tstr_modtype of Ident.t * module_type
- | Tstr_open of Path.t
-- | Tstr_class of (Ident.t * int * string list * class_expr) list
-+ | Tstr_class of
-+ (Ident.t * int * string list * class_expr * virtual_flag) list
- | Tstr_cltype of (Ident.t * cltype_declaration) list
- | Tstr_include of module_expr * Ident.t list
-
-Index: typing/typedtree.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typedtree.mli,v
-retrieving revision 1.34
-diff -u -r1.34 typedtree.mli
---- typing/typedtree.mli 25 Nov 2003 09:20:43 -0000 1.34
-+++ typing/typedtree.mli 5 Apr 2006 02:26:00 -0000
-@@ -107,7 +107,8 @@
- and class_field =
- Cf_inher of class_expr * (string * Ident.t) list * (string * Ident.t) list
- (* Inherited instance variables and concrete methods *)
-- | Cf_val of string * Ident.t * expression
-+ | Cf_val of string * Ident.t * expression option * bool
-+ (* None = virtual, true = override *)
- | Cf_meth of string * expression
- | Cf_let of rec_flag * (pattern * expression) list *
- (Ident.t * expression) list
-@@ -141,7 +142,8 @@
- | Tstr_recmodule of (Ident.t * module_expr) list
- | Tstr_modtype of Ident.t * module_type
- | Tstr_open of Path.t
-- | Tstr_class of (Ident.t * int * string list * class_expr) list
-+ | Tstr_class of
-+ (Ident.t * int * string list * class_expr * virtual_flag) list
- | Tstr_cltype of (Ident.t * cltype_declaration) list
- | Tstr_include of module_expr * Ident.t list
-
-Index: typing/typemod.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typemod.ml,v
-retrieving revision 1.73
-diff -u -r1.73 typemod.ml
---- typing/typemod.ml 8 Aug 2005 09:41:51 -0000 1.73
-+++ typing/typemod.ml 5 Apr 2006 02:26:00 -0000
-@@ -17,6 +17,7 @@
- open Misc
- open Longident
- open Path
-+open Asttypes
- open Parsetree
- open Types
- open Typedtree
-@@ -667,8 +668,9 @@
- let (classes, new_env) = Typeclass.class_declarations env cl in
- let (str_rem, sig_rem, final_env) = type_struct new_env srem in
- (Tstr_class
-- (List.map (fun (i, _,_,_,_,_,_,_, s, m, c) ->
-- (i, s, m, c)) classes) ::
-+ (List.map (fun (i, d, _,_,_,_,_,_, s, m, c) ->
-+ let vf = if d.cty_new = None then Virtual else Concrete in
-+ (i, s, m, c, vf)) classes) ::
- Tstr_cltype
- (List.map (fun (_,_, i, d, _,_,_,_,_,_,_) -> (i, d)) classes) ::
- Tstr_type
-Index: typing/types.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/types.ml,v
-retrieving revision 1.25
-diff -u -r1.25 types.ml
---- typing/types.ml 9 Dec 2004 12:40:53 -0000 1.25
-+++ typing/types.ml 5 Apr 2006 02:26:00 -0000
-@@ -90,7 +90,8 @@
- | Val_prim of Primitive.description (* Primitive *)
- | Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *)
- | Val_self of (Ident.t * type_expr) Meths.t ref *
-- (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
-+ (Ident.t * Asttypes.mutable_flag *
-+ Asttypes.virtual_flag * type_expr) Vars.t ref *
- string * type_expr
- (* Self *)
- | Val_anc of (string * Ident.t) list * string
-@@ -156,7 +157,8 @@
-
- and class_signature =
- { cty_self: type_expr;
-- cty_vars: (Asttypes.mutable_flag * type_expr) Vars.t;
-+ cty_vars:
-+ (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t;
- cty_concr: Concr.t;
- cty_inher: (Path.t * type_expr list) list }
-
-Index: typing/types.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/types.mli,v
-retrieving revision 1.25
-diff -u -r1.25 types.mli
---- typing/types.mli 9 Dec 2004 12:40:53 -0000 1.25
-+++ typing/types.mli 5 Apr 2006 02:26:00 -0000
-@@ -91,7 +91,8 @@
- | Val_prim of Primitive.description (* Primitive *)
- | Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *)
- | Val_self of (Ident.t * type_expr) Meths.t ref *
-- (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
-+ (Ident.t * Asttypes.mutable_flag *
-+ Asttypes.virtual_flag * type_expr) Vars.t ref *
- string * type_expr
- (* Self *)
- | Val_anc of (string * Ident.t) list * string
-@@ -158,7 +159,8 @@
-
- and class_signature =
- { cty_self: type_expr;
-- cty_vars: (Asttypes.mutable_flag * type_expr) Vars.t;
-+ cty_vars:
-+ (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t;
- cty_concr: Concr.t;
- cty_inher: (Path.t * type_expr list) list }
-
-Index: typing/unused_var.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/unused_var.ml,v
-retrieving revision 1.5
-diff -u -r1.5 unused_var.ml
---- typing/unused_var.ml 4 Jan 2006 16:55:50 -0000 1.5
-+++ typing/unused_var.ml 5 Apr 2006 02:26:00 -0000
-@@ -245,7 +245,7 @@
- match cf with
- | Pcf_inher (ce, _) -> class_expr ppf tbl ce;
- | Pcf_val (_, _, e, _) -> expression ppf tbl e;
-- | Pcf_virt _ -> ()
-+ | Pcf_virt _ | Pcf_valvirt _ -> ()
- | Pcf_meth (_, _, e, _) -> expression ppf tbl e;
- | Pcf_cstr _ -> ()
- | Pcf_let (recflag, pel, _) -> let_pel ppf tbl recflag pel None;
-Index: bytecomp/translclass.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translclass.ml,v
-retrieving revision 1.38
-diff -u -r1.38 translclass.ml
---- bytecomp/translclass.ml 13 Aug 2005 20:59:37 -0000 1.38
-+++ bytecomp/translclass.ml 5 Apr 2006 02:26:00 -0000
-@@ -133,10 +133,10 @@
- (fun _ -> lambda_unit) cl
- in
- (inh_init, lsequence obj_init' obj_init, true)
-- | Cf_val (_, id, exp) ->
-+ | Cf_val (_, id, Some exp, _) ->
- (inh_init, lsequence (set_inst_var obj id exp) obj_init,
- has_init)
-- | Cf_meth _ ->
-+ | Cf_meth _ | Cf_val _ ->
- (inh_init, obj_init, has_init)
- | Cf_init _ ->
- (inh_init, obj_init, true)
-@@ -213,27 +213,17 @@
- if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else
- if len = 0 && nvals < 2 then transl_vals tbl true vals cl_init else
- let ids = Ident.create "ids" in
-- let i = ref len in
-- let getter, names, cl_init =
-- match vals with [] -> "get_method_labels", [], cl_init
-- | (_,id0)::vals' ->
-- incr i;
-- let i = ref (List.length vals) in
-- "new_methods_variables",
-- [transl_meth_list (List.map fst vals)],
-- Llet(Strict, id0, lfield ids 0,
-- List.fold_right
-- (fun (name,id) rem ->
-- decr i;
-- Llet(Alias, id, Lprim(Poffsetint !i, [Lvar id0]), rem))
-- vals' cl_init)
-+ let i = ref (len + nvals) in
-+ let getter, names =
-+ if nvals = 0 then "get_method_labels", [] else
-+ "new_methods_variables", [transl_meth_list (List.map fst vals)]
- in
- Llet(StrictOpt, ids,
- Lapply (oo_prim getter,
- [Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
- List.fold_right
- (fun (lab,id) lam -> decr i; Llet(StrictOpt, id, lfield ids !i, lam))
-- methl cl_init)
-+ (methl @ vals) cl_init)
-
- let output_methods tbl methods lam =
- match methods with
-@@ -283,8 +273,9 @@
- (vals, meths_super cla str.cl_meths meths)
- inh_init cl_init msubst top cl in
- (inh_init, cl_init, [], values)
-- | Cf_val (name, id, exp) ->
-- (inh_init, cl_init, methods, (name, id)::values)
-+ | Cf_val (name, id, exp, over) ->
-+ let values = if over then values else (name, id) :: values in
-+ (inh_init, cl_init, methods, values)
- | Cf_meth (name, exp) ->
- let met_code = msubst true (transl_exp exp) in
- let met_code =
-@@ -342,27 +333,24 @@
- assert (Path.same path path');
- let lpath = transl_path path in
- let inh = Ident.create "inh"
-- and inh_vals = Ident.create "vals"
-- and inh_meths = Ident.create "meths"
-+ and ofs = List.length vals + 1
- and valids, methids = super in
- let cl_init =
- List.fold_left
- (fun init (nm, id, _) ->
-- Llet(StrictOpt, id, lfield inh_meths (index nm concr_meths),
-+ Llet(StrictOpt, id, lfield inh (index nm concr_meths + ofs),
- init))
- cl_init methids in
- let cl_init =
- List.fold_left
- (fun init (nm, id) ->
-- Llet(StrictOpt, id, lfield inh_vals (index nm vals), init))
-+ Llet(StrictOpt, id, lfield inh (index nm vals + 1), init))
- cl_init valids in
- (inh_init,
- Llet (Strict, inh,
- Lapply(oo_prim "inherits", narrow_args @
- [lpath; Lconst(Const_pointer(if top then 1 else 0))]),
-- Llet(StrictOpt, obj_init, lfield inh 0,
-- Llet(Alias, inh_vals, lfield inh 1,
-- Llet(Alias, inh_meths, lfield inh 2, cl_init)))))
-+ Llet(StrictOpt, obj_init, lfield inh 0, cl_init)))
- | _ ->
- let core cl_init =
- build_class_init cla true super inh_init cl_init msubst top cl
-@@ -397,12 +385,16 @@
- XXX Il devrait etre peu couteux d'ecrire des classes :
- class c x y = d e f
- *)
--let rec transl_class_rebind obj_init cl =
-+let rec transl_class_rebind obj_init cl vf =
- match cl.cl_desc with
- Tclass_ident path ->
-+ if vf = Concrete then begin
-+ try if (Env.find_class path cl.cl_env).cty_new = None then raise Exit
-+ with Not_found -> raise Exit
-+ end;
- (path, obj_init)
- | Tclass_fun (pat, _, cl, partial) ->
-- let path, obj_init = transl_class_rebind obj_init cl in
-+ let path, obj_init = transl_class_rebind obj_init cl vf in
- let build params rem =
- let param = name_pattern "param" [pat, ()] in
- Lfunction (Curried, param::params,
-@@ -414,14 +406,14 @@
- Lfunction (Curried, params, rem) -> build params rem
- | rem -> build [] rem)
- | Tclass_apply (cl, oexprs) ->
-- let path, obj_init = transl_class_rebind obj_init cl in
-+ let path, obj_init = transl_class_rebind obj_init cl vf in
- (path, transl_apply obj_init oexprs)
- | Tclass_let (rec_flag, defs, vals, cl) ->
-- let path, obj_init = transl_class_rebind obj_init cl in
-+ let path, obj_init = transl_class_rebind obj_init cl vf in
- (path, Translcore.transl_let rec_flag defs obj_init)
- | Tclass_structure _ -> raise Exit
- | Tclass_constraint (cl', _, _, _) ->
-- let path, obj_init = transl_class_rebind obj_init cl' in
-+ let path, obj_init = transl_class_rebind obj_init cl' vf in
- let rec check_constraint = function
- Tcty_constr(path', _, _) when Path.same path path' -> ()
- | Tcty_fun (_, _, cty) -> check_constraint cty
-@@ -430,21 +422,21 @@
- check_constraint cl.cl_type;
- (path, obj_init)
-
--let rec transl_class_rebind_0 self obj_init cl =
-+let rec transl_class_rebind_0 self obj_init cl vf =
- match cl.cl_desc with
- Tclass_let (rec_flag, defs, vals, cl) ->
-- let path, obj_init = transl_class_rebind_0 self obj_init cl in
-+ let path, obj_init = transl_class_rebind_0 self obj_init cl vf in
- (path, Translcore.transl_let rec_flag defs obj_init)
- | _ ->
-- let path, obj_init = transl_class_rebind obj_init cl in
-+ let path, obj_init = transl_class_rebind obj_init cl vf in
- (path, lfunction [self] obj_init)
-
--let transl_class_rebind ids cl =
-+let transl_class_rebind ids cl vf =
- try
- let obj_init = Ident.create "obj_init"
- and self = Ident.create "self" in
- let obj_init0 = lapply (Lvar obj_init) [Lvar self] in
-- let path, obj_init' = transl_class_rebind_0 self obj_init0 cl in
-+ let path, obj_init' = transl_class_rebind_0 self obj_init0 cl vf in
- if not (Translcore.check_recursive_lambda ids obj_init') then
- raise(Error(cl.cl_loc, Illegal_class_expr));
- let id = (obj_init' = lfunction [self] obj_init0) in
-@@ -592,9 +584,9 @@
- *)
-
-
--let transl_class ids cl_id arity pub_meths cl =
-+let transl_class ids cl_id arity pub_meths cl vflag =
- (* First check if it is not only a rebind *)
-- let rebind = transl_class_rebind ids cl in
-+ let rebind = transl_class_rebind ids cl vflag in
- if rebind <> lambda_unit then rebind else
-
- (* Prepare for heavy environment handling *)
-@@ -696,9 +688,7 @@
- (* Simplest case: an object defined at toplevel (ids=[]) *)
- if top && ids = [] then llets (ltable cla (ldirect obj_init)) else
-
-- let concrete =
-- ids = [] ||
-- Typeclass.virtual_methods (Ctype.signature_of_class_type cl.cl_type) = []
-+ let concrete = (vflag = Concrete)
- and lclass lam =
- let cl_init = llets (Lfunction(Curried, [cla], cl_init)) in
- Llet(Strict, class_init, cl_init, lam (free_variables cl_init))
-@@ -800,11 +790,11 @@
-
- (* Wrapper for class compilation *)
-
--let transl_class ids cl_id arity pub_meths cl =
-- oo_wrap cl.cl_env false (transl_class ids cl_id arity pub_meths) cl
-+let transl_class ids cl_id arity pub_meths cl vf =
-+ oo_wrap cl.cl_env false (transl_class ids cl_id arity pub_meths cl) vf
-
- let () =
-- transl_object := (fun id meths cl -> transl_class [] id 0 meths cl)
-+ transl_object := (fun id meths cl -> transl_class [] id 0 meths cl Concrete)
-
- (* Error report *)
-
-Index: bytecomp/translclass.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translclass.mli,v
-retrieving revision 1.11
-diff -u -r1.11 translclass.mli
---- bytecomp/translclass.mli 12 Aug 2004 12:55:11 -0000 1.11
-+++ bytecomp/translclass.mli 5 Apr 2006 02:26:00 -0000
-@@ -16,7 +16,8 @@
- open Lambda
-
- val transl_class :
-- Ident.t list -> Ident.t -> int -> string list -> class_expr -> lambda;;
-+ Ident.t list -> Ident.t ->
-+ int -> string list -> class_expr -> Asttypes.virtual_flag -> lambda;;
-
- type error = Illegal_class_expr | Tags of string * string
-
-Index: bytecomp/translmod.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translmod.ml,v
-retrieving revision 1.51
-diff -u -r1.51 translmod.ml
---- bytecomp/translmod.ml 12 Aug 2004 12:55:11 -0000 1.51
-+++ bytecomp/translmod.ml 5 Apr 2006 02:26:00 -0000
-@@ -317,10 +317,10 @@
- | Tstr_open path :: rem ->
- transl_structure fields cc rootpath rem
- | Tstr_class cl_list :: rem ->
-- let ids = List.map (fun (i, _, _, _) -> i) cl_list in
-+ let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in
- Lletrec(List.map
-- (fun (id, arity, meths, cl) ->
-- (id, transl_class ids id arity meths cl))
-+ (fun (id, arity, meths, cl, vf) ->
-+ (id, transl_class ids id arity meths cl vf))
- cl_list,
- transl_structure (List.rev ids @ fields) cc rootpath rem)
- | Tstr_cltype cl_list :: rem ->
-@@ -414,11 +414,11 @@
- | Tstr_open path :: rem ->
- transl_store subst rem
- | Tstr_class cl_list :: rem ->
-- let ids = List.map (fun (i, _, _, _) -> i) cl_list in
-+ let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in
- let lam =
- Lletrec(List.map
-- (fun (id, arity, meths, cl) ->
-- (id, transl_class ids id arity meths cl))
-+ (fun (id, arity, meths, cl, vf) ->
-+ (id, transl_class ids id arity meths cl vf))
- cl_list,
- store_idents ids) in
- Lsequence(subst_lambda subst lam,
-@@ -485,7 +485,7 @@
- | Tstr_modtype(id, decl) :: rem -> defined_idents rem
- | Tstr_open path :: rem -> defined_idents rem
- | Tstr_class cl_list :: rem ->
-- List.map (fun (i, _, _, _) -> i) cl_list @ defined_idents rem
-+ List.map (fun (i, _, _, _, _) -> i) cl_list @ defined_idents rem
- | Tstr_cltype cl_list :: rem -> defined_idents rem
- | Tstr_include(modl, ids) :: rem -> ids @ defined_idents rem
-
-@@ -603,14 +603,14 @@
- | Tstr_class cl_list ->
- (* we need to use unique names for the classes because there might
- be a value named identically *)
-- let ids = List.map (fun (i, _, _, _) -> i) cl_list in
-+ let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in
- List.iter set_toplevel_unique_name ids;
- Lletrec(List.map
-- (fun (id, arity, meths, cl) ->
-- (id, transl_class ids id arity meths cl))
-+ (fun (id, arity, meths, cl, vf) ->
-+ (id, transl_class ids id arity meths cl vf))
- cl_list,
- make_sequence
-- (fun (id, _, _, _) -> toploop_setvalue_id id)
-+ (fun (id, _, _, _, _) -> toploop_setvalue_id id)
- cl_list)
- | Tstr_cltype cl_list ->
- lambda_unit
-Index: driver/main_args.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/driver/main_args.ml,v
-retrieving revision 1.48
-diff -u -r1.48 main_args.ml
---- driver/main_args.ml 4 Jan 2006 16:55:49 -0000 1.48
-+++ driver/main_args.ml 5 Apr 2006 02:26:00 -0000
-@@ -136,11 +136,11 @@
- \032 E/e enable/disable fragile match\n\
- \032 F/f enable/disable partially applied function\n\
- \032 L/l enable/disable labels omitted in application\n\
-- \032 M/m enable/disable overridden method\n\
-+ \032 M/m enable/disable overridden methods\n\
- \032 P/p enable/disable partial match\n\
- \032 S/s enable/disable non-unit statement\n\
- \032 U/u enable/disable unused match case\n\
-- \032 V/v enable/disable hidden instance variable\n\
-+ \032 V/v enable/disable overridden instance variables\n\
- \032 Y/y enable/disable suspicious unused variables\n\
- \032 Z/z enable/disable all other unused variables\n\
- \032 X/x enable/disable all other warnings\n\
-Index: driver/optmain.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/driver/optmain.ml,v
-retrieving revision 1.87
-diff -u -r1.87 optmain.ml
---- driver/optmain.ml 4 Jan 2006 16:55:49 -0000 1.87
-+++ driver/optmain.ml 5 Apr 2006 02:26:00 -0000
-@@ -173,7 +173,7 @@
- \032 P/p enable/disable partial match\n\
- \032 S/s enable/disable non-unit statement\n\
- \032 U/u enable/disable unused match case\n\
-- \032 V/v enable/disable hidden instance variables\n\
-+ \032 V/v enable/disable overridden instance variables\n\
- \032 Y/y enable/disable suspicious unused variables\n\
- \032 Z/z enable/disable all other unused variables\n\
- \032 X/x enable/disable all other warnings\n\
-Index: stdlib/camlinternalOO.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.ml,v
-retrieving revision 1.14
-diff -u -r1.14 camlinternalOO.ml
---- stdlib/camlinternalOO.ml 25 Oct 2005 18:34:07 -0000 1.14
-+++ stdlib/camlinternalOO.ml 5 Apr 2006 02:26:00 -0000
-@@ -206,7 +206,11 @@
- (table.methods_by_name, table.methods_by_label, table.hidden_meths,
- table.vars, virt_meth_labs, vars)
- :: table.previous_states;
-- table.vars <- Vars.empty;
-+ table.vars <-
-+ Vars.fold
-+ (fun lab info tvars ->
-+ if List.mem lab vars then Vars.add lab info tvars else tvars)
-+ table.vars Vars.empty;
- let by_name = ref Meths.empty in
- let by_label = ref Labs.empty in
- List.iter2
-@@ -255,9 +259,11 @@
- index
-
- let new_variable table name =
-- let index = new_slot table in
-- table.vars <- Vars.add name index table.vars;
-- index
-+ try Vars.find name table.vars
-+ with Not_found ->
-+ let index = new_slot table in
-+ table.vars <- Vars.add name index table.vars;
-+ index
-
- let to_array arr =
- if arr = Obj.magic 0 then [||] else arr
-@@ -265,16 +271,17 @@
- let new_methods_variables table meths vals =
- let meths = to_array meths in
- let nmeths = Array.length meths and nvals = Array.length vals in
-- let index = new_variable table vals.(0) in
-- let res = Array.create (nmeths + 1) index in
-- for i = 1 to nvals - 1 do ignore (new_variable table vals.(i)) done;
-+ let res = Array.create (nmeths + nvals) 0 in
- for i = 0 to nmeths - 1 do
-- res.(i+1) <- get_method_label table meths.(i)
-+ res.(i) <- get_method_label table meths.(i)
-+ done;
-+ for i = 0 to nvals - 1 do
-+ res.(i+nmeths) <- new_variable table vals.(i)
- done;
- res
-
- let get_variable table name =
-- Vars.find name table.vars
-+ try Vars.find name table.vars with Not_found -> assert false
-
- let get_variables table names =
- Array.map (get_variable table) names
-@@ -315,9 +322,12 @@
- let init =
- if top then super cla env else Obj.repr (super cla) in
- widen cla;
-- (init, Array.map (get_variable cla) (to_array vals),
-- Array.map (fun nm -> get_method cla (get_method_label cla nm))
-- (to_array concr_meths))
-+ Array.concat
-+ [[| repr init |];
-+ magic (Array.map (get_variable cla) (to_array vals) : int array);
-+ Array.map
-+ (fun nm -> repr (get_method cla (get_method_label cla nm) : closure))
-+ (to_array concr_meths) ]
-
- let make_class pub_meths class_init =
- let table = create_table pub_meths in
-Index: stdlib/camlinternalOO.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.mli,v
-retrieving revision 1.9
-diff -u -r1.9 camlinternalOO.mli
---- stdlib/camlinternalOO.mli 25 Oct 2005 18:34:07 -0000 1.9
-+++ stdlib/camlinternalOO.mli 5 Apr 2006 02:26:00 -0000
-@@ -46,8 +46,7 @@
- val init_class : table -> unit
- val inherits :
- table -> string array -> string array -> string array ->
-- (t * (table -> obj -> Obj.t) * t * obj) -> bool ->
-- (Obj.t * int array * closure array)
-+ (t * (table -> obj -> Obj.t) * t * obj) -> bool -> Obj.t array
- val make_class :
- string array -> (table -> Obj.t -> t) ->
- (t * (table -> Obj.t -> t) * (Obj.t -> t) * Obj.t)
-@@ -79,6 +78,7 @@
-
- (** {6 Builtins to reduce code size} *)
-
-+(*
- val get_const : t -> closure
- val get_var : int -> closure
- val get_env : int -> int -> closure
-@@ -103,6 +103,7 @@
- val send_var : tag -> int -> int -> closure
- val send_env : tag -> int -> int -> int -> closure
- val send_meth : tag -> label -> int -> closure
-+*)
-
- type impl =
- GetConst
-Index: stdlib/sys.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/stdlib/sys.ml,v
-retrieving revision 1.142
-diff -u -r1.142 sys.ml
---- stdlib/sys.ml 22 Mar 2006 12:39:39 -0000 1.142
-+++ stdlib/sys.ml 5 Apr 2006 02:26:00 -0000
-@@ -78,4 +78,4 @@
-
- (* OCaml version string, must be in the format described in sys.mli. *)
-
--let ocaml_version = "3.10+dev4 (2006-03-22)";;
-+let ocaml_version = "3.10+dev5 (2006-04-05)";;
-Index: tools/depend.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/tools/depend.ml,v
-retrieving revision 1.9
-diff -u -r1.9 depend.ml
---- tools/depend.ml 23 Mar 2005 03:08:37 -0000 1.9
-+++ tools/depend.ml 5 Apr 2006 02:26:00 -0000
-@@ -87,7 +87,7 @@
-
- and add_class_type_field bv = function
- Pctf_inher cty -> add_class_type bv cty
-- | Pctf_val(_, _, oty, _) -> add_opt add_type bv oty
-+ | Pctf_val(_, _, _, ty, _) -> add_type bv ty
- | Pctf_virt(_, _, ty, _) -> add_type bv ty
- | Pctf_meth(_, _, ty, _) -> add_type bv ty
- | Pctf_cstr(ty1, ty2, _) -> add_type bv ty1; add_type bv ty2
-@@ -280,6 +280,7 @@
- and add_class_field bv = function
- Pcf_inher(ce, _) -> add_class_expr bv ce
- | Pcf_val(_, _, e, _) -> add_expr bv e
-+ | Pcf_valvirt(_, _, ty, _)
- | Pcf_virt(_, _, ty, _) -> add_type bv ty
- | Pcf_meth(_, _, e, _) -> add_expr bv e
- | Pcf_cstr(ty1, ty2, _) -> add_type bv ty1; add_type bv ty2
-Index: tools/ocamlprof.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/tools/ocamlprof.ml,v
-retrieving revision 1.38
-diff -u -r1.38 ocamlprof.ml
---- tools/ocamlprof.ml 24 Mar 2005 17:20:54 -0000 1.38
-+++ tools/ocamlprof.ml 5 Apr 2006 02:26:00 -0000
-@@ -328,7 +328,7 @@
- rewrite_patexp_list iflag spat_sexp_list
- | Pcf_init sexp ->
- rewrite_exp iflag sexp
-- | Pcf_virt _ | Pcf_cstr _ -> ()
-+ | Pcf_valvirt _ | Pcf_virt _ | Pcf_cstr _ -> ()
-
- and rewrite_class_expr iflag cexpr =
- match cexpr.pcl_desc with
-Index: otherlibs/labltk/browser/searchpos.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/otherlibs/labltk/browser/searchpos.ml,v
-retrieving revision 1.48
-diff -u -r1.48 searchpos.ml
---- otherlibs/labltk/browser/searchpos.ml 23 Mar 2005 03:08:37 -0000 1.48
-+++ otherlibs/labltk/browser/searchpos.ml 5 Apr 2006 02:26:01 -0000
-@@ -141,9 +141,8 @@
- List.iter cfl ~f:
- begin function
- Pctf_inher cty -> search_pos_class_type cty ~pos ~env
-- | Pctf_val (_, _, Some ty, loc) ->
-+ | Pctf_val (_, _, _, ty, loc) ->
- if in_loc loc ~pos then search_pos_type ty ~pos ~env
-- | Pctf_val _ -> ()
- | Pctf_virt (_, _, ty, loc) ->
- if in_loc loc ~pos then search_pos_type ty ~pos ~env
- | Pctf_meth (_, _, ty, loc) ->
-@@ -675,7 +674,7 @@
- | Tstr_modtype _ -> ()
- | Tstr_open _ -> ()
- | Tstr_class l ->
-- List.iter l ~f:(fun (id, _, _, cl) -> search_pos_class_expr cl ~pos)
-+ List.iter l ~f:(fun (id, _, _, cl, _) -> search_pos_class_expr cl ~pos)
- | Tstr_cltype _ -> ()
- | Tstr_include (m, _) -> search_pos_module_expr m ~pos
- end
-@@ -685,7 +684,8 @@
- begin function
- Cf_inher (cl, _, _) ->
- search_pos_class_expr cl ~pos
-- | Cf_val (_, _, exp) -> search_pos_expr exp ~pos
-+ | Cf_val (_, _, Some exp, _) -> search_pos_expr exp ~pos
-+ | Cf_val _ -> ()
- | Cf_meth (_, exp) -> search_pos_expr exp ~pos
- | Cf_let (_, pel, iel) ->
- List.iter pel ~f:
-Index: ocamldoc/Makefile
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/ocamldoc/Makefile,v
-retrieving revision 1.61
-diff -u -r1.61 Makefile
---- ocamldoc/Makefile 4 Jan 2006 16:55:49 -0000 1.61
-+++ ocamldoc/Makefile 5 Apr 2006 02:26:01 -0000
-@@ -31,7 +31,7 @@
- MKDIR=mkdir -p
- CP=cp -f
- OCAMLDOC=ocamldoc
--OCAMLDOC_RUN=sh ./runocamldoc $(SUPPORTS_SHARED_LIBRARIES)
-+OCAMLDOC_RUN=./ocamldoc.opt #sh ./runocamldoc $(SUPPORTS_SHARED_LIBRARIES)
- OCAMLDOC_OPT=$(OCAMLDOC).opt
- OCAMLDOC_LIBCMA=odoc_info.cma
- OCAMLDOC_LIBCMI=odoc_info.cmi
-@@ -188,12 +188,12 @@
- ../otherlibs/num/num.mli
-
- all: exe lib
-- $(MAKE) manpages
-
- exe: $(OCAMLDOC)
- lib: $(OCAMLDOC_LIBCMA) $(OCAMLDOC_LIBCMI) $(ODOC_TEST)
-
- opt.opt: exeopt libopt
-+ $(MAKE) manpages
- exeopt: $(OCAMLDOC_OPT)
- libopt: $(OCAMLDOC_LIBCMXA) $(OCAMLDOC_LIBCMI)
- debug:
-Index: ocamldoc/odoc_ast.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/ocamldoc/odoc_ast.ml,v
-retrieving revision 1.27
-diff -u -r1.27 odoc_ast.ml
---- ocamldoc/odoc_ast.ml 4 Jan 2006 16:55:49 -0000 1.27
-+++ ocamldoc/odoc_ast.ml 5 Apr 2006 02:26:01 -0000
-@@ -88,7 +88,7 @@
- ident_type_decl_list
- | Typedtree.Tstr_class info_list ->
- List.iter
-- (fun ((id,_,_,_) as ci) ->
-+ (fun ((id,_,_,_,_) as ci) ->
- Hashtbl.add table (C (Name.from_ident id))
- (Typedtree.Tstr_class [ci]))
- info_list
-@@ -146,7 +146,7 @@
-
- let search_class_exp table name =
- match Hashtbl.find table (C name) with
-- | (Typedtree.Tstr_class [(_,_,_,ce)]) ->
-+ | (Typedtree.Tstr_class [(_,_,_,ce,_)]) ->
- (
- try
- let type_decl = search_type_declaration table name in
-@@ -184,7 +184,7 @@
- let rec iter = function
- | [] ->
- raise Not_found
-- | Typedtree.Cf_val (_, ident, exp) :: q
-+ | Typedtree.Cf_val (_, ident, Some exp, _) :: q
- when Name.from_ident ident = name ->
- exp.Typedtree.exp_type
- | _ :: q ->
-@@ -523,7 +523,8 @@
- p_clexp.Parsetree.pcl_loc.Location.loc_end.Lexing.pos_cnum
- q
-
-- | (Parsetree.Pcf_val (label, mutable_flag, expression, loc)) :: q ->
-+ | (Parsetree.Pcf_val (label, mutable_flag, _, loc) |
-+ Parsetree.Pcf_valvirt (label, mutable_flag, _, loc)) :: q ->
- let complete_name = Name.concat current_class_name label in
- let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
- let type_exp =
-Index: ocamldoc/odoc_sig.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/ocamldoc/odoc_sig.ml,v
-retrieving revision 1.37
-diff -u -r1.37 odoc_sig.ml
---- ocamldoc/odoc_sig.ml 4 Jan 2006 16:55:50 -0000 1.37
-+++ ocamldoc/odoc_sig.ml 5 Apr 2006 02:26:01 -0000
-@@ -107,7 +107,7 @@
- | _ -> assert false
-
- let search_attribute_type name class_sig =
-- let (_, type_expr) = Types.Vars.find name class_sig.Types.cty_vars in
-+ let (_, _, type_expr) = Types.Vars.find name class_sig.Types.cty_vars in
- type_expr
-
- let search_method_type name class_sig =
-@@ -269,7 +269,7 @@
- [] -> pos_limit
- | ele2 :: _ ->
- match ele2 with
-- Parsetree.Pctf_val (_, _, _, loc)
-+ Parsetree.Pctf_val (_, _, _, _, loc)
- | Parsetree.Pctf_virt (_, _, _, loc)
- | Parsetree.Pctf_meth (_, _, _, loc)
- | Parsetree.Pctf_cstr (_, _, loc) -> loc.Location.loc_start.Lexing.pos_cnum
-@@ -330,7 +330,7 @@
- in
- ([], ele_comments)
-
-- | Parsetree.Pctf_val (name, mutable_flag, _, loc) :: q ->
-+ | Parsetree.Pctf_val (name, mutable_flag, _, _, loc) :: q ->
- (* of (string * mutable_flag * core_type option * Location.t)*)
- let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
- let complete_name = Name.concat current_class_name name in
-Index: camlp4/camlp4/ast2pt.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/camlp4/ast2pt.ml,v
-retrieving revision 1.36
-diff -u -r1.36 ast2pt.ml
---- camlp4/camlp4/ast2pt.ml 29 Jun 2005 04:11:26 -0000 1.36
-+++ camlp4/camlp4/ast2pt.ml 5 Apr 2006 02:26:01 -0000
-@@ -244,6 +244,7 @@
- ;
- value mkmutable m = if m then Mutable else Immutable;
- value mkprivate m = if m then Private else Public;
-+value mkvirtual m = if m then Virtual else Concrete;
- value mktrecord (loc, n, m, t) =
- (n, mkmutable m, ctyp (mkpolytype t), mkloc loc);
- value mkvariant (loc, c, tl) = (c, List.map ctyp tl, mkloc loc);
-@@ -862,8 +863,8 @@
- | CgInh loc ct -> [Pctf_inher (class_type ct) :: l]
- | CgMth loc s pf t ->
- [Pctf_meth (s, mkprivate pf, ctyp (mkpolytype t), mkloc loc) :: l]
-- | CgVal loc s b t ->
-- [Pctf_val (s, mkmutable b, Some (ctyp t), mkloc loc) :: l]
-+ | CgVal loc s b v t ->
-+ [Pctf_val (s, mkmutable b, mkvirtual v, ctyp t, mkloc loc) :: l]
- | CgVir loc s b t ->
- [Pctf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l] ]
- and class_expr =
-@@ -907,7 +908,9 @@
- [Pcf_meth (s, mkprivate b, e, mkloc loc) :: l]
- | CrVal loc s b e -> [Pcf_val (s, mkmutable b, expr e, mkloc loc) :: l]
- | CrVir loc s b t ->
-- [Pcf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l] ]
-+ [Pcf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l]
-+ | CrVvr loc s b t ->
-+ [Pcf_valvirt (s, mkmutable b, ctyp t, mkloc loc) :: l] ]
- ;
-
- value interf ast = List.fold_right sig_item ast [];
-Index: camlp4/camlp4/mLast.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/camlp4/mLast.mli,v
-retrieving revision 1.18
-diff -u -r1.18 mLast.mli
---- camlp4/camlp4/mLast.mli 29 Jun 2005 04:11:26 -0000 1.18
-+++ camlp4/camlp4/mLast.mli 5 Apr 2006 02:26:01 -0000
-@@ -180,7 +180,7 @@
- | CgDcl of loc and list class_sig_item
- | CgInh of loc and class_type
- | CgMth of loc and string and bool and ctyp
-- | CgVal of loc and string and bool and ctyp
-+ | CgVal of loc and string and bool and bool and ctyp
- | CgVir of loc and string and bool and ctyp ]
- and class_expr =
- [ CeApp of loc and class_expr and expr
-@@ -196,7 +196,8 @@
- | CrIni of loc and expr
- | CrMth of loc and string and bool and expr and option ctyp
- | CrVal of loc and string and bool and expr
-- | CrVir of loc and string and bool and ctyp ]
-+ | CrVir of loc and string and bool and ctyp
-+ | CrVvr of loc and string and bool and ctyp ]
- ;
-
- external loc_of_ctyp : ctyp -> loc = "%field0";
-Index: camlp4/camlp4/reloc.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/camlp4/reloc.ml,v
-retrieving revision 1.18
-diff -u -r1.18 reloc.ml
---- camlp4/camlp4/reloc.ml 29 Jun 2005 04:11:26 -0000 1.18
-+++ camlp4/camlp4/reloc.ml 5 Apr 2006 02:26:01 -0000
-@@ -350,7 +350,7 @@
- | CgDcl loc x1 -> let nloc = floc loc in CgDcl nloc (List.map (class_sig_item floc sh) x1)
- | CgInh loc x1 -> let nloc = floc loc in CgInh nloc (class_type floc sh x1)
- | CgMth loc x1 x2 x3 -> let nloc = floc loc in CgMth nloc x1 x2 (ctyp floc sh x3)
-- | CgVal loc x1 x2 x3 -> let nloc = floc loc in CgVal nloc x1 x2 (ctyp floc sh x3)
-+ | CgVal loc x1 x2 x3 x4 -> let nloc = floc loc in CgVal nloc x1 x2 x3 (ctyp floc sh x4)
- | CgVir loc x1 x2 x3 -> let nloc = floc loc in CgVir nloc x1 x2 (ctyp floc sh x3) ]
- and class_expr floc sh =
- self where rec self =
-@@ -377,5 +377,6 @@
- | CrMth loc x1 x2 x3 x4 ->
- let nloc = floc loc in CrMth nloc x1 x2 (expr floc sh x3) (option_map (ctyp floc sh) x4)
- | CrVal loc x1 x2 x3 -> let nloc = floc loc in CrVal nloc x1 x2 (expr floc sh x3)
-- | CrVir loc x1 x2 x3 -> let nloc = floc loc in CrVir nloc x1 x2 (ctyp floc sh x3) ]
-+ | CrVir loc x1 x2 x3 -> let nloc = floc loc in CrVir nloc x1 x2 (ctyp floc sh x3)
-+ | CrVvr loc x1 x2 x3 -> let nloc = floc loc in CrVvr nloc x1 x2 (ctyp floc sh x3) ]
- ;
-Index: camlp4/etc/pa_o.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/etc/pa_o.ml,v
-retrieving revision 1.66
-diff -u -r1.66 pa_o.ml
---- camlp4/etc/pa_o.ml 29 Jun 2005 04:11:26 -0000 1.66
-+++ camlp4/etc/pa_o.ml 5 Apr 2006 02:26:01 -0000
-@@ -1037,8 +1037,14 @@
- class_str_item:
- [ [ "inherit"; ce = class_expr; pb = OPT [ "as"; i = LIDENT -> i ] ->
- <:class_str_item< inherit $ce$ $opt:pb$ >>
-- | "val"; mf = OPT "mutable"; lab = label; e = cvalue_binding ->
-- <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >>
-+ | "val"; "mutable"; lab = label; e = cvalue_binding ->
-+ <:class_str_item< value mutable $lab$ = $e$ >>
-+ | "val"; lab = label; e = cvalue_binding ->
-+ <:class_str_item< value $lab$ = $e$ >>
-+ | "val"; "mutable"; "virtual"; lab = label; ":"; t = ctyp ->
-+ <:class_str_item< value virtual mutable $lab$ : $t$ >>
-+ | "val"; "virtual"; mf = OPT "mutable"; lab = label; ":"; t = ctyp ->
-+ <:class_str_item< value virtual $opt:o2b mf$ $lab$ : $t$ >>
- | "method"; "private"; "virtual"; l = label; ":"; t = poly_type ->
- <:class_str_item< method virtual private $l$ : $t$ >>
- | "method"; "virtual"; "private"; l = label; ":"; t = poly_type ->
-@@ -1087,8 +1093,9 @@
- ;
- class_sig_item:
- [ [ "inherit"; cs = class_signature -> <:class_sig_item< inherit $cs$ >>
-- | "val"; mf = OPT "mutable"; l = label; ":"; t = ctyp ->
-- <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >>
-+ | "val"; mf = OPT "mutable"; vf = OPT "virtual";
-+ l = label; ":"; t = ctyp ->
-+ <:class_sig_item< value $opt:o2b mf$ $opt:o2b vf$ $l$ : $t$ >>
- | "method"; "private"; "virtual"; l = label; ":"; t = poly_type ->
- <:class_sig_item< method virtual private $l$ : $t$ >>
- | "method"; "virtual"; "private"; l = label; ":"; t = poly_type ->
-Index: camlp4/etc/pr_o.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/etc/pr_o.ml,v
-retrieving revision 1.51
-diff -u -r1.51 pr_o.ml
---- camlp4/etc/pr_o.ml 5 Jan 2006 10:44:29 -0000 1.51
-+++ camlp4/etc/pr_o.ml 5 Apr 2006 02:26:01 -0000
-@@ -1768,10 +1768,11 @@
- [: `S LR "method"; private_flag pf; `label lab;
- `S LR ":" :];
- `ctyp t "" k :]
-- | MLast.CgVal _ lab mf t ->
-+ | MLast.CgVal _ lab mf vf t ->
- fun curr next dg k ->
- [: `HVbox
-- [: `S LR "val"; mutable_flag mf; `label lab; `S LR ":" :];
-+ [: `S LR "val"; mutable_flag mf; virtual_flag vf;
-+ `label lab; `S LR ":" :];
- `ctyp t "" k :]
- | MLast.CgVir _ lab pf t ->
- fun curr next dg k ->
-Index: camlp4/meta/pa_r.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/meta/pa_r.ml,v
-retrieving revision 1.64
-diff -u -r1.64 pa_r.ml
---- camlp4/meta/pa_r.ml 29 Jun 2005 04:11:26 -0000 1.64
-+++ camlp4/meta/pa_r.ml 5 Apr 2006 02:26:01 -0000
-@@ -658,7 +658,9 @@
- | "inherit"; ce = class_expr; pb = OPT as_lident ->
- <:class_str_item< inherit $ce$ $opt:pb$ >>
- | "value"; mf = OPT "mutable"; lab = label; e = cvalue_binding ->
-- <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >>
-+ <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >>
-+ | "value"; "virtual"; mf = OPT "mutable"; l = label; ":"; t = ctyp ->
-+ <:class_str_item< value virtual $opt:o2b mf$ $l$ : $t$ >>
- | "method"; "virtual"; pf = OPT "private"; l = label; ":"; t = ctyp ->
- <:class_str_item< method virtual $opt:o2b pf$ $l$ : $t$ >>
- | "method"; pf = OPT "private"; l = label; topt = OPT polyt;
-@@ -701,8 +703,9 @@
- [ [ "declare"; st = LIST0 [ s = class_sig_item; ";" -> s ]; "end" ->
- <:class_sig_item< declare $list:st$ end >>
- | "inherit"; cs = class_type -> <:class_sig_item< inherit $cs$ >>
-- | "value"; mf = OPT "mutable"; l = label; ":"; t = ctyp ->
-- <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >>
-+ | "value"; mf = OPT "mutable"; vf = OPT "virtual";
-+ l = label; ":"; t = ctyp ->
-+ <:class_sig_item< value $opt:o2b mf$ $opt:o2b vf$ $l$ : $t$ >>
- | "method"; "virtual"; pf = OPT "private"; l = label; ":"; t = ctyp ->
- <:class_sig_item< method virtual $opt:o2b pf$ $l$ : $t$ >>
- | "method"; pf = OPT "private"; l = label; ":"; t = ctyp ->
-Index: camlp4/meta/q_MLast.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/meta/q_MLast.ml,v
-retrieving revision 1.60
-diff -u -r1.60 q_MLast.ml
---- camlp4/meta/q_MLast.ml 29 Jun 2005 04:11:26 -0000 1.60
-+++ camlp4/meta/q_MLast.ml 5 Apr 2006 02:26:01 -0000
-@@ -947,6 +947,8 @@
- Qast.Node "CrDcl" [Qast.Loc; st]
- | "inherit"; ce = class_expr; pb = SOPT as_lident ->
- Qast.Node "CrInh" [Qast.Loc; ce; pb]
-+ | "value"; "virtual"; mf = SOPT "mutable"; l = label; ":"; t = ctyp ->
-+ Qast.Node "CrVvr" [Qast.Loc; l; o2b mf; t]
- | "value"; mf = SOPT "mutable"; lab = label; e = cvalue_binding ->
- Qast.Node "CrVal" [Qast.Loc; lab; o2b mf; e]
- | "method"; "virtual"; pf = SOPT "private"; l = label; ":"; t = ctyp ->
-@@ -992,8 +994,9 @@
- [ [ "declare"; st = SLIST0 [ s = class_sig_item; ";" -> s ]; "end" ->
- Qast.Node "CgDcl" [Qast.Loc; st]
- | "inherit"; cs = class_type -> Qast.Node "CgInh" [Qast.Loc; cs]
-- | "value"; mf = SOPT "mutable"; l = label; ":"; t = ctyp ->
-- Qast.Node "CgVal" [Qast.Loc; l; o2b mf; t]
-+ | "value"; mf = SOPT "mutable"; vf = SOPT "virtual";
-+ l = label; ":"; t = ctyp ->
-+ Qast.Node "CgVal" [Qast.Loc; l; o2b mf; o2b vf; t]
- | "method"; "virtual"; pf = SOPT "private"; l = label; ":"; t = ctyp ->
- Qast.Node "CgVir" [Qast.Loc; l; o2b pf; t]
- | "method"; pf = SOPT "private"; l = label; ":"; t = ctyp ->
-Index: camlp4/ocaml_src/camlp4/ast2pt.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/camlp4/ast2pt.ml,v
-retrieving revision 1.36
-diff -u -r1.36 ast2pt.ml
---- camlp4/ocaml_src/camlp4/ast2pt.ml 29 Jun 2005 04:11:26 -0000 1.36
-+++ camlp4/ocaml_src/camlp4/ast2pt.ml 5 Apr 2006 02:26:01 -0000
-@@ -227,6 +227,7 @@
- ;;
- let mkmutable m = if m then Mutable else Immutable;;
- let mkprivate m = if m then Private else Public;;
-+let mkvirtual m = if m then Virtual else Concrete;;
- let mktrecord (loc, n, m, t) =
- n, mkmutable m, ctyp (mkpolytype t), mkloc loc
- ;;
-@@ -878,8 +879,8 @@
- | CgInh (loc, ct) -> Pctf_inher (class_type ct) :: l
- | CgMth (loc, s, pf, t) ->
- Pctf_meth (s, mkprivate pf, ctyp (mkpolytype t), mkloc loc) :: l
-- | CgVal (loc, s, b, t) ->
-- Pctf_val (s, mkmutable b, Some (ctyp t), mkloc loc) :: l
-+ | CgVal (loc, s, b, v, t) ->
-+ Pctf_val (s, mkmutable b, mkvirtual v, ctyp t, mkloc loc) :: l
- | CgVir (loc, s, b, t) ->
- Pctf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l
- and class_expr =
-@@ -923,6 +924,8 @@
- | CrVal (loc, s, b, e) -> Pcf_val (s, mkmutable b, expr e, mkloc loc) :: l
- | CrVir (loc, s, b, t) ->
- Pcf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l
-+ | CrVvr (loc, s, b, t) ->
-+ Pcf_valvirt (s, mkmutable b, ctyp t, mkloc loc) :: l
- ;;
-
- let interf ast = List.fold_right sig_item ast [];;
-Index: camlp4/ocaml_src/camlp4/mLast.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/camlp4/mLast.mli,v
-retrieving revision 1.20
-diff -u -r1.20 mLast.mli
---- camlp4/ocaml_src/camlp4/mLast.mli 29 Jun 2005 04:11:26 -0000 1.20
-+++ camlp4/ocaml_src/camlp4/mLast.mli 5 Apr 2006 02:26:01 -0000
-@@ -180,7 +180,7 @@
- | CgDcl of loc * class_sig_item list
- | CgInh of loc * class_type
- | CgMth of loc * string * bool * ctyp
-- | CgVal of loc * string * bool * ctyp
-+ | CgVal of loc * string * bool * bool * ctyp
- | CgVir of loc * string * bool * ctyp
- and class_expr =
- CeApp of loc * class_expr * expr
-@@ -197,6 +197,7 @@
- | CrMth of loc * string * bool * expr * ctyp option
- | CrVal of loc * string * bool * expr
- | CrVir of loc * string * bool * ctyp
-+ | CrVvr of loc * string * bool * ctyp
- ;;
-
- external loc_of_ctyp : ctyp -> loc = "%field0";;
-Index: camlp4/ocaml_src/camlp4/reloc.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/camlp4/reloc.ml,v
-retrieving revision 1.20
-diff -u -r1.20 reloc.ml
---- camlp4/ocaml_src/camlp4/reloc.ml 29 Jun 2005 04:11:26 -0000 1.20
-+++ camlp4/ocaml_src/camlp4/reloc.ml 5 Apr 2006 02:26:01 -0000
-@@ -430,8 +430,8 @@
- let nloc = floc loc in CgInh (nloc, class_type floc sh x1)
- | CgMth (loc, x1, x2, x3) ->
- let nloc = floc loc in CgMth (nloc, x1, x2, ctyp floc sh x3)
-- | CgVal (loc, x1, x2, x3) ->
-- let nloc = floc loc in CgVal (nloc, x1, x2, ctyp floc sh x3)
-+ | CgVal (loc, x1, x2, x3, x4) ->
-+ let nloc = floc loc in CgVal (nloc, x1, x2, x3, ctyp floc sh x4)
- | CgVir (loc, x1, x2, x3) ->
- let nloc = floc loc in CgVir (nloc, x1, x2, ctyp floc sh x3)
- in
-@@ -478,6 +478,8 @@
- let nloc = floc loc in CrVal (nloc, x1, x2, expr floc sh x3)
- | CrVir (loc, x1, x2, x3) ->
- let nloc = floc loc in CrVir (nloc, x1, x2, ctyp floc sh x3)
-+ | CrVvr (loc, x1, x2, x3) ->
-+ let nloc = floc loc in CrVvr (nloc, x1, x2, ctyp floc sh x3)
- in
- self
- ;;
-Index: camlp4/ocaml_src/meta/pa_r.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/meta/pa_r.ml,v
-retrieving revision 1.59
-diff -u -r1.59 pa_r.ml
---- camlp4/ocaml_src/meta/pa_r.ml 29 Jun 2005 04:11:26 -0000 1.59
-+++ camlp4/ocaml_src/meta/pa_r.ml 5 Apr 2006 02:26:01 -0000
-@@ -2161,6 +2161,15 @@
- (fun (t : 'ctyp) _ (l : 'label) (pf : string option) _ _
- (_loc : Lexing.position * Lexing.position) ->
- (MLast.CrVir (_loc, l, o2b pf, t) : 'class_str_item));
-+ [Gramext.Stoken ("", "value"); Gramext.Stoken ("", "virtual");
-+ Gramext.Sopt (Gramext.Stoken ("", "mutable"));
-+ Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
-+ Gramext.Stoken ("", ":");
-+ Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
-+ Gramext.action
-+ (fun (t : 'ctyp) _ (l : 'label) (mf : string option) _ _
-+ (_loc : Lexing.position * Lexing.position) ->
-+ (MLast.CrVvr (_loc, l, o2b mf, t) : 'class_str_item));
- [Gramext.Stoken ("", "value");
- Gramext.Sopt (Gramext.Stoken ("", "mutable"));
- Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
-@@ -2338,13 +2347,15 @@
- (MLast.CgVir (_loc, l, o2b pf, t) : 'class_sig_item));
- [Gramext.Stoken ("", "value");
- Gramext.Sopt (Gramext.Stoken ("", "mutable"));
-+ Gramext.Sopt (Gramext.Stoken ("", "virtual"));
- Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
- Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action
-- (fun (t : 'ctyp) _ (l : 'label) (mf : string option) _
-+ (fun (t : 'ctyp) _ (l : 'label) (vf : string option)
-+ (mf : string option) _
- (_loc : Lexing.position * Lexing.position) ->
-- (MLast.CgVal (_loc, l, o2b mf, t) : 'class_sig_item));
-+ (MLast.CgVal (_loc, l, o2b mf, o2b vf, t) : 'class_sig_item));
- [Gramext.Stoken ("", "inherit");
- Gramext.Snterm
- (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))],
-Index: camlp4/ocaml_src/meta/q_MLast.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/meta/q_MLast.ml,v
-retrieving revision 1.65
-diff -u -r1.65 q_MLast.ml
---- camlp4/ocaml_src/meta/q_MLast.ml 12 Jan 2006 08:54:21 -0000 1.65
-+++ camlp4/ocaml_src/meta/q_MLast.ml 5 Apr 2006 02:26:01 -0000
-@@ -3152,9 +3152,9 @@
- Gramext.action
- (fun (x : string)
- (_loc : Lexing.position * Lexing.position) ->
-- (Qast.Str x : 'e__17))])],
-+ (Qast.Str x : 'e__18))])],
- Gramext.action
-- (fun (a : 'e__17 option)
-+ (fun (a : 'e__18 option)
- (_loc : Lexing.position * Lexing.position) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
-@@ -3191,9 +3191,9 @@
- Gramext.action
- (fun (x : string)
- (_loc : Lexing.position * Lexing.position) ->
-- (Qast.Str x : 'e__16))])],
-+ (Qast.Str x : 'e__17))])],
- Gramext.action
-- (fun (a : 'e__16 option)
-+ (fun (a : 'e__17 option)
- (_loc : Lexing.position * Lexing.position) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
-@@ -3216,9 +3216,9 @@
- Gramext.action
- (fun (x : string)
- (_loc : Lexing.position * Lexing.position) ->
-- (Qast.Str x : 'e__15))])],
-+ (Qast.Str x : 'e__16))])],
- Gramext.action
-- (fun (a : 'e__15 option)
-+ (fun (a : 'e__16 option)
- (_loc : Lexing.position * Lexing.position) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
-@@ -3235,6 +3235,31 @@
- (_loc : Lexing.position * Lexing.position) ->
- (Qast.Node ("CrVal", [Qast.Loc; lab; o2b mf; e]) :
- 'class_str_item));
-+ [Gramext.Stoken ("", "value"); Gramext.Stoken ("", "virtual");
-+ Gramext.srules
-+ [[Gramext.Sopt
-+ (Gramext.srules
-+ [[Gramext.Stoken ("", "mutable")],
-+ Gramext.action
-+ (fun (x : string)
-+ (_loc : Lexing.position * Lexing.position) ->
-+ (Qast.Str x : 'e__15))])],
-+ Gramext.action
-+ (fun (a : 'e__15 option)
-+ (_loc : Lexing.position * Lexing.position) ->
-+ (Qast.Option a : 'a_opt));
-+ [Gramext.Snterm
-+ (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
-+ Gramext.action
-+ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
-+ (a : 'a_opt))];
-+ Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
-+ Gramext.Stoken ("", ":");
-+ Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
-+ Gramext.action
-+ (fun (t : 'ctyp) _ (l : 'label) (mf : 'a_opt) _ _
-+ (_loc : Lexing.position * Lexing.position) ->
-+ (Qast.Node ("CrVvr", [Qast.Loc; l; o2b mf; t]) : 'class_str_item));
- [Gramext.Stoken ("", "inherit");
- Gramext.Snterm
- (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e));
-@@ -3366,9 +3391,9 @@
- Gramext.action
- (fun _ (csf : 'class_sig_item)
- (_loc : Lexing.position * Lexing.position) ->
-- (csf : 'e__18))])],
-+ (csf : 'e__19))])],
- Gramext.action
-- (fun (a : 'e__18 list)
-+ (fun (a : 'e__19 list)
- (_loc : Lexing.position * Lexing.position) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
-@@ -3446,9 +3471,9 @@
- Gramext.action
- (fun (x : string)
- (_loc : Lexing.position * Lexing.position) ->
-- (Qast.Str x : 'e__22))])],
-+ (Qast.Str x : 'e__24))])],
- Gramext.action
-- (fun (a : 'e__22 option)
-+ (fun (a : 'e__24 option)
- (_loc : Lexing.position * Lexing.position) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
-@@ -3471,9 +3496,9 @@
- Gramext.action
- (fun (x : string)
- (_loc : Lexing.position * Lexing.position) ->
-- (Qast.Str x : 'e__21))])],
-+ (Qast.Str x : 'e__23))])],
- Gramext.action
-- (fun (a : 'e__21 option)
-+ (fun (a : 'e__23 option)
- (_loc : Lexing.position * Lexing.position) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
-@@ -3496,9 +3521,26 @@
- Gramext.action
- (fun (x : string)
- (_loc : Lexing.position * Lexing.position) ->
-- (Qast.Str x : 'e__20))])],
-+ (Qast.Str x : 'e__21))])],
- Gramext.action
-- (fun (a : 'e__20 option)
-+ (fun (a : 'e__21 option)
-+ (_loc : Lexing.position * Lexing.position) ->
-+ (Qast.Option a : 'a_opt));
-+ [Gramext.Snterm
-+ (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
-+ Gramext.action
-+ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
-+ (a : 'a_opt))];
-+ Gramext.srules
-+ [[Gramext.Sopt
-+ (Gramext.srules
-+ [[Gramext.Stoken ("", "virtual")],
-+ Gramext.action
-+ (fun (x : string)
-+ (_loc : Lexing.position * Lexing.position) ->
-+ (Qast.Str x : 'e__22))])],
-+ Gramext.action
-+ (fun (a : 'e__22 option)
- (_loc : Lexing.position * Lexing.position) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
-@@ -3510,9 +3552,10 @@
- Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action
-- (fun (t : 'ctyp) _ (l : 'label) (mf : 'a_opt) _
-+ (fun (t : 'ctyp) _ (l : 'label) (vf : 'a_opt) (mf : 'a_opt) _
- (_loc : Lexing.position * Lexing.position) ->
-- (Qast.Node ("CgVal", [Qast.Loc; l; o2b mf; t]) : 'class_sig_item));
-+ (Qast.Node ("CgVal", [Qast.Loc; l; o2b mf; o2b vf; t]) :
-+ 'class_sig_item));
- [Gramext.Stoken ("", "inherit");
- Gramext.Snterm
- (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))],
-@@ -3531,9 +3574,9 @@
- Gramext.action
- (fun _ (s : 'class_sig_item)
- (_loc : Lexing.position * Lexing.position) ->
-- (s : 'e__19))])],
-+ (s : 'e__20))])],
- Gramext.action
-- (fun (a : 'e__19 list)
-+ (fun (a : 'e__20 list)
- (_loc : Lexing.position * Lexing.position) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
-@@ -3556,9 +3599,9 @@
- Gramext.action
- (fun (x : string)
- (_loc : Lexing.position * Lexing.position) ->
-- (Qast.Str x : 'e__23))])],
-+ (Qast.Str x : 'e__25))])],
- Gramext.action
-- (fun (a : 'e__23 option)
-+ (fun (a : 'e__25 option)
- (_loc : Lexing.position * Lexing.position) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
-@@ -3593,9 +3636,9 @@
- Gramext.action
- (fun (x : string)
- (_loc : Lexing.position * Lexing.position) ->
-- (Qast.Str x : 'e__24))])],
-+ (Qast.Str x : 'e__26))])],
- Gramext.action
-- (fun (a : 'e__24 option)
-+ (fun (a : 'e__26 option)
- (_loc : Lexing.position * Lexing.position) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
-@@ -3713,9 +3756,9 @@
- Gramext.action
- (fun (x : string)
- (_loc : Lexing.position * Lexing.position) ->
-- (Qast.Str x : 'e__25))])],
-+ (Qast.Str x : 'e__27))])],
- Gramext.action
-- (fun (a : 'e__25 option)
-+ (fun (a : 'e__27 option)
- (_loc : Lexing.position * Lexing.position) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
-@@ -3922,9 +3965,9 @@
- Gramext.action
- (fun (x : string)
- (_loc : Lexing.position * Lexing.position) ->
-- (Qast.Str x : 'e__26))])],
-+ (Qast.Str x : 'e__28))])],
- Gramext.action
-- (fun (a : 'e__26 option)
-+ (fun (a : 'e__28 option)
- (_loc : Lexing.position * Lexing.position) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
-@@ -4390,9 +4433,9 @@
- Gramext.action
- (fun _ (e : 'expr)
- (_loc : Lexing.position * Lexing.position) ->
-- (e : 'e__29))])],
-+ (e : 'e__31))])],
- Gramext.action
-- (fun (a : 'e__29 list)
-+ (fun (a : 'e__31 list)
- (_loc : Lexing.position * Lexing.position) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
-@@ -4425,9 +4468,9 @@
- Gramext.action
- (fun _ (e : 'expr)
- (_loc : Lexing.position * Lexing.position) ->
-- (e : 'e__28))])],
-+ (e : 'e__30))])],
- Gramext.action
-- (fun (a : 'e__28 list)
-+ (fun (a : 'e__30 list)
- (_loc : Lexing.position * Lexing.position) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
-@@ -4454,9 +4497,9 @@
- Gramext.action
- (fun _ (e : 'expr)
- (_loc : Lexing.position * Lexing.position) ->
-- (e : 'e__27))])],
-+ (e : 'e__29))])],
- Gramext.action
-- (fun (a : 'e__27 list)
-+ (fun (a : 'e__29 list)
- (_loc : Lexing.position * Lexing.position) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
-@@ -4547,9 +4590,9 @@
- Gramext.action
- (fun _ (cf : 'class_str_item)
- (_loc : Lexing.position * Lexing.position) ->
-- (cf : 'e__30))])],
-+ (cf : 'e__32))])],
- Gramext.action
-- (fun (a : 'e__30 list)
-+ (fun (a : 'e__32 list)
- (_loc : Lexing.position * Lexing.position) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
-@@ -4592,9 +4635,9 @@
- Gramext.action
- (fun _ (csf : 'class_sig_item)
- (_loc : Lexing.position * Lexing.position) ->
-- (csf : 'e__32))])],
-+ (csf : 'e__34))])],
- Gramext.action
-- (fun (a : 'e__32 list)
-+ (fun (a : 'e__34 list)
- (_loc : Lexing.position * Lexing.position) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
-@@ -4623,9 +4666,9 @@
- Gramext.action
- (fun _ (csf : 'class_sig_item)
- (_loc : Lexing.position * Lexing.position) ->
-- (csf : 'e__31))])],
-+ (csf : 'e__33))])],
- Gramext.action
-- (fun (a : 'e__31 list)
-+ (fun (a : 'e__33 list)
- (_loc : Lexing.position * Lexing.position) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
-Index: camlp4/top/rprint.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/top/rprint.ml,v
-retrieving revision 1.18
-diff -u -r1.18 rprint.ml
---- camlp4/top/rprint.ml 29 Jun 2005 04:11:26 -0000 1.18
-+++ camlp4/top/rprint.ml 5 Apr 2006 02:26:01 -0000
-@@ -288,8 +288,9 @@
- fprintf ppf "@[<2>method %s%s%s :@ %a;@]"
- (if priv then "private " else "") (if virt then "virtual " else "")
- name Toploop.print_out_type.val ty
-- | Ocsg_value name mut ty ->
-- fprintf ppf "@[<2>value %s%s :@ %a;@]" (if mut then "mutable " else "")
-+ | Ocsg_value name mut virt ty ->
-+ fprintf ppf "@[<2>value %s%s%s :@ %a;@]"
-+ (if mut then "mutable " else "") (if virt then "virtual " else "")
- name Toploop.print_out_type.val ty ]
- ;
-
+++ /dev/null
-Index: VERSION
-===================================================================
---- VERSION (リビジョン 11207)
-+++ VERSION (作æ¥ã‚³ãƒ”ー)
-@@ -1,4 +1,4 @@
--3.13.0+dev6 (2011-07-29)
-+3.13.0+dev7 (2011-09-22)
-
- # The version string is the first line of this file.
- # It must be in the format described in stdlib/sys.mli
-Index: typing/typemod.ml
-===================================================================
---- typing/typemod.ml (リビジョン 11207)
-+++ typing/typemod.ml (作æ¥ã‚³ãƒ”ー)
-@@ -764,7 +764,7 @@
- Location.prerr_warning smod.pmod_loc
- (Warnings.Not_principal "this module unpacking");
- modtype_of_package env smod.pmod_loc p nl tl
-- | {desc = Tvar} ->
-+ | {desc = Tvar _} ->
- raise (Typecore.Error
- (smod.pmod_loc, Typecore.Cannot_infer_signature))
- | _ ->
-Index: typing/typetexp.ml
-===================================================================
---- typing/typetexp.ml (リビジョン 11207)
-+++ typing/typetexp.ml (作æ¥ã‚³ãƒ”ー)
-@@ -150,7 +150,7 @@
- if strict then raise Already_bound;
- v
- with Not_found ->
-- let v = new_global_var() in
-+ let v = new_global_var ~name () in
- type_variables := Tbl.add name v !type_variables;
- v
-
-@@ -165,8 +165,8 @@
- Tpoly _ -> ty
- | _ -> Ctype.newty (Tpoly (ty, []))
-
--let new_pre_univar () =
-- let v = newvar () in pre_univars := v :: !pre_univars; v
-+let new_pre_univar ?name () =
-+ let v = newvar ?name () in pre_univars := v :: !pre_univars; v
-
- let rec swap_list = function
- x :: y :: l -> y :: x :: swap_list l
-@@ -190,7 +190,8 @@
- instance (fst(Tbl.find name !used_variables))
- with Not_found ->
- let v =
-- if policy = Univars then new_pre_univar () else newvar () in
-+ if policy = Univars then new_pre_univar ~name () else newvar ~name ()
-+ in
- used_variables := Tbl.add name (v, styp.ptyp_loc) !used_variables;
- v
- end
-@@ -333,7 +334,14 @@
- end_def ();
- generalize_structure t;
- end;
-- instance t
-+ let t = instance t in
-+ let px = Btype.proxy t in
-+ begin match px.desc with
-+ | Tvar None -> Btype.log_type px; px.desc <- Tvar (Some alias)
-+ | Tunivar None -> Btype.log_type px; px.desc <- Tunivar (Some alias)
-+ | _ -> ()
-+ end;
-+ t
- end
- | Ptyp_variant(fields, closed, present) ->
- let name = ref None in
-@@ -388,7 +396,7 @@
- {desc=Tvariant row}, _ when Btype.static_row row ->
- let row = Btype.row_repr row in
- row.row_fields
-- | {desc=Tvar}, Some(p, _) ->
-+ | {desc=Tvar _}, Some(p, _) ->
- raise(Error(sty.ptyp_loc, Unbound_type_constructor_2 p))
- | _ ->
- raise(Error(sty.ptyp_loc, Not_a_variant ty))
-@@ -431,7 +439,7 @@
- newty (Tvariant row)
- | Ptyp_poly(vars, st) ->
- begin_def();
-- let new_univars = List.map (fun name -> name, newvar()) vars in
-+ let new_univars = List.map (fun name -> name, newvar ~name ()) vars in
- let old_univars = !univars in
- univars := new_univars @ !univars;
- let ty = transl_type env policy st in
-@@ -443,10 +451,12 @@
- (fun tyl (name, ty1) ->
- let v = Btype.proxy ty1 in
- if deep_occur v ty then begin
-- if v.level <> Btype.generic_level || v.desc <> Tvar then
-- raise (Error (styp.ptyp_loc, Cannot_quantify (name, v)));
-- v.desc <- Tunivar;
-- v :: tyl
-+ match v.desc with
-+ Tvar name when v.level = Btype.generic_level ->
-+ v.desc <- Tunivar name;
-+ v :: tyl
-+ | _ ->
-+ raise (Error (styp.ptyp_loc, Cannot_quantify (name, v)))
- end else tyl)
- [] new_univars
- in
-@@ -483,7 +493,7 @@
- match ty.desc with
- | Tvariant row ->
- let row = Btype.row_repr row in
-- if (Btype.row_more row).desc = Tunivar then
-+ if Btype.is_Tunivar (Btype.row_more row) then
- ty.desc <- Tvariant
- {row with row_fixed=true;
- row_fields = List.map
-@@ -512,7 +522,7 @@
- then try
- r := (loc, v, Tbl.find name !type_variables) :: !r
- with Not_found ->
-- if fixed && (repr ty).desc = Tvar then
-+ if fixed && Btype.is_Tvar (repr ty) then
- raise(Error(loc, Unbound_type_variable ("'"^name)));
- let v2 = new_global_var () in
- r := (loc, v, v2) :: !r;
-@@ -552,8 +562,10 @@
- List.fold_left
- (fun acc v ->
- let v = repr v in
-- if v.level <> Btype.generic_level || v.desc <> Tvar then acc
-- else (v.desc <- Tunivar ; v :: acc))
-+ match v.desc with
-+ Tvar name when v.level = Btype.generic_level ->
-+ v.desc <- Tunivar name; v :: acc
-+ | _ -> acc)
- [] !pre_univars
- in
- make_fixed_univars typ;
-@@ -635,8 +647,8 @@
- fprintf ppf "The type variable name %s is not allowed in programs" name
- | Cannot_quantify (name, v) ->
- fprintf ppf "This type scheme cannot quantify '%s :@ %s." name
-- (if v.desc = Tvar then "it escapes this scope" else
-- if v.desc = Tunivar then "it is aliased to another variable"
-+ (if Btype.is_Tvar v then "it escapes this scope" else
-+ if Btype.is_Tunivar v then "it is aliased to another variable"
- else "it is not a variable")
- | Multiple_constraints_on_type s ->
- fprintf ppf "Multiple constraints for type %s" s
-Index: typing/btype.ml
-===================================================================
---- typing/btype.ml (リビジョン 11207)
-+++ typing/btype.ml (作æ¥ã‚³ãƒ”ー)
-@@ -35,9 +35,9 @@
- let new_id = ref (-1)
-
- let newty2 level desc =
-- incr new_id; { desc = desc; level = level; id = !new_id }
-+ incr new_id; { desc; level; id = !new_id }
- let newgenty desc = newty2 generic_level desc
--let newgenvar () = newgenty Tvar
-+let newgenvar ?name () = newgenty (Tvar name)
- (*
- let newmarkedvar level =
- incr new_id; { desc = Tvar; level = pivot_level - level; id = !new_id }
-@@ -46,6 +46,11 @@
- { desc = Tvar; level = pivot_level - generic_level; id = !new_id }
- *)
-
-+(**** Check some types ****)
-+
-+let is_Tvar = function {desc=Tvar _} -> true | _ -> false
-+let is_Tunivar = function {desc=Tunivar _} -> true | _ -> false
-+
- (**** Representative of a type ****)
-
- let rec field_kind_repr =
-@@ -139,7 +144,7 @@
- let rec proxy_obj ty =
- match ty.desc with
- Tfield (_, _, _, ty) | Tlink ty -> proxy_obj ty
-- | Tvar | Tunivar | Tconstr _ -> ty
-+ | Tvar _ | Tunivar _ | Tconstr _ -> ty
- | Tnil -> ty0
- | _ -> assert false
- in proxy_obj ty
-@@ -180,13 +185,13 @@
- row.row_fields;
- match (repr row.row_more).desc with
- Tvariant row -> iter_row f row
-- | Tvar | Tunivar | Tsubst _ | Tconstr _ ->
-+ | Tvar _ | Tunivar _ | Tsubst _ | Tconstr _ ->
- Misc.may (fun (_,l) -> List.iter f l) row.row_name
- | _ -> assert false
-
- let iter_type_expr f ty =
- match ty.desc with
-- Tvar -> ()
-+ Tvar _ -> ()
- | Tarrow (_, ty1, ty2, _) -> f ty1; f ty2
- | Ttuple l -> List.iter f l
- | Tconstr (_, l, _) -> List.iter f l
-@@ -198,7 +203,7 @@
- | Tnil -> ()
- | Tlink ty -> f ty
- | Tsubst ty -> f ty
-- | Tunivar -> ()
-+ | Tunivar _ -> ()
- | Tpoly (ty, tyl) -> f ty; List.iter f tyl
- | Tpackage (_, _, l) -> List.iter f l
-
-@@ -239,13 +244,13 @@
- encoding during substitution *)
- let rec norm_univar ty =
- match ty.desc with
-- Tunivar | Tsubst _ -> ty
-+ Tunivar _ | Tsubst _ -> ty
- | Tlink ty -> norm_univar ty
- | Ttuple (ty :: _) -> norm_univar ty
- | _ -> assert false
-
- let rec copy_type_desc f = function
-- Tvar -> Tvar
-+ Tvar _ -> Tvar None (* forget the name *)
- | Tarrow (p, ty1, ty2, c)-> Tarrow (p, f ty1, f ty2, copy_commu c)
- | Ttuple l -> Ttuple (List.map f l)
- | Tconstr (p, l, _) -> Tconstr (p, List.map f l, ref Mnil)
-@@ -258,7 +263,7 @@
- | Tnil -> Tnil
- | Tlink ty -> copy_type_desc f ty.desc
- | Tsubst ty -> assert false
-- | Tunivar -> Tunivar
-+ | Tunivar _ as ty -> ty (* keep the name *)
- | Tpoly (ty, tyl) ->
- let tyl = List.map (fun x -> norm_univar (f x)) tyl in
- Tpoly (f ty, tyl)
-@@ -447,7 +452,7 @@
- | Cuniv of type_expr option ref * type_expr option
-
- let undo_change = function
-- Ctype (ty, desc) -> ty.desc <- desc
-+ Ctype (ty, desc) -> ty.desc <- desc
- | Clevel (ty, level) -> ty.level <- level
- | Cname (r, v) -> r := v
- | Crow (r, v) -> r := v
-@@ -474,7 +479,22 @@
-
- let log_type ty =
- if ty.id <= !last_snapshot then log_change (Ctype (ty, ty.desc))
--let link_type ty ty' = log_type ty; ty.desc <- Tlink ty'
-+let link_type ty ty' =
-+ log_type ty;
-+ let desc = ty.desc in
-+ ty.desc <- Tlink ty';
-+ (* Name is a user-supplied name for this unification variable (obtained
-+ * through a type annotation for instance). *)
-+ match desc, ty'.desc with
-+ Tvar name, Tvar name' ->
-+ begin match name, name' with
-+ | Some _, None -> log_type ty'; ty'.desc <- Tvar name
-+ | None, Some _ -> ()
-+ | Some _, Some _ ->
-+ if ty.level < ty'.level then (log_type ty'; ty'.desc <- Tvar name)
-+ | None, None -> ()
-+ end
-+ | _ -> ()
- (* ; assert (check_memorized_abbrevs ()) *)
- (* ; check_expans [] ty' *)
- let set_level ty level =
-Index: typing/typecore.ml
-===================================================================
---- typing/typecore.ml (リビジョン 11207)
-+++ typing/typecore.ml (作æ¥ã‚³ãƒ”ー)
-@@ -633,7 +633,7 @@
- List.iter generalize vars;
- let instantiated tv =
- let tv = expand_head !env tv in
-- tv.desc <> Tvar || tv.level <> generic_level in
-+ not (is_Tvar tv) || tv.level <> generic_level in
- if List.exists instantiated vars then
- raise (Error(loc, Polymorphic_label (lid_of_label label)))
- end;
-@@ -1126,7 +1126,7 @@
- Tarrow (l, _, ty_res, _) ->
- list_labels_aux env (ty::visited) (l::ls) ty_res
- | _ ->
-- List.rev ls, ty.desc = Tvar
-+ List.rev ls, is_Tvar ty
-
- let list_labels env ty = list_labels_aux env [] [] ty
-
-@@ -1142,9 +1142,10 @@
- (fun t ->
- let t = repr t in
- generalize t;
-- if t.desc = Tvar && t.level = generic_level then
-- (log_type t; t.desc <- Tunivar; true)
-- else false)
-+ match t.desc with
-+ Tvar name when t.level = generic_level ->
-+ log_type t; t.desc <- Tunivar name; true
-+ | _ -> false)
- vars in
- if List.length vars = List.length vars' then () else
- let ty = newgenty (Tpoly(repr exp.exp_type, vars'))
-@@ -1158,7 +1159,7 @@
- match (expand_head env exp.exp_type).desc with
- | Tarrow _ ->
- Location.prerr_warning exp.exp_loc Warnings.Partial_application
-- | Tvar -> ()
-+ | Tvar _ -> ()
- | Tconstr (p, _, _) when Path.same p Predef.path_unit -> ()
- | _ ->
- if statement then
-@@ -1742,7 +1743,7 @@
- let (id, typ) =
- filter_self_method env met Private meths privty
- in
-- if (repr typ).desc = Tvar then
-+ if is_Tvar (repr typ) then
- Location.prerr_warning loc
- (Warnings.Undeclared_virtual_method met);
- (Texp_send(obj, Tmeth_val id), typ)
-@@ -1797,7 +1798,7 @@
- Location.prerr_warning loc
- (Warnings.Not_principal "this use of a polymorphic method");
- snd (instance_poly false tl ty)
-- | {desc = Tvar} as ty ->
-+ | {desc = Tvar _} as ty ->
- let ty' = newvar () in
- unify env (instance ty) (newty(Tpoly(ty',[])));
- (* if not !Clflags.nolabels then
-@@ -1979,7 +1980,7 @@
- end_def ();
- check_univars env false "method" exp ty_expected vars;
- re { exp with exp_type = instance ty }
-- | Tvar ->
-+ | Tvar _ ->
- let exp = type_exp env sbody in
- let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in
- unify_exp env exp ty;
-@@ -2038,7 +2039,7 @@
- Location.prerr_warning loc
- (Warnings.Not_principal "this module packing");
- (p, nl, tl)
-- | {desc = Tvar} ->
-+ | {desc = Tvar _} ->
- raise (Error (loc, Cannot_infer_signature))
- | _ ->
- raise (Error (loc, Not_a_packed_module ty_expected))
-@@ -2128,7 +2129,7 @@
- ty_fun
- | Tarrow (l,_,ty_res',_) when l = "" || !Clflags.classic ->
- args, ty_fun, no_labels ty_res'
-- | Tvar -> args, ty_fun, false
-+ | Tvar _ -> args, ty_fun, false
- | _ -> [], texp.exp_type, false
- in
- let args, ty_fun', simple_res = make_args [] texp.exp_type in
-@@ -2192,7 +2193,7 @@
- let (ty1, ty2) =
- let ty_fun = expand_head env ty_fun in
- match ty_fun.desc with
-- Tvar ->
-+ Tvar _ ->
- let t1 = newvar () and t2 = newvar () in
- let not_identity = function
- Texp_ident(_,{val_kind=Val_prim
-@@ -2335,7 +2336,7 @@
- begin match (expand_head env exp.exp_type).desc with
- | Tarrow _ ->
- Location.prerr_warning exp.exp_loc Warnings.Partial_application
-- | Tvar ->
-+ | Tvar _ ->
- add_delayed_check (fun () -> check_application_result env false exp)
- | _ -> ()
- end;
-@@ -2404,9 +2405,9 @@
- | Tarrow _ ->
- Location.prerr_warning loc Warnings.Partial_application
- | Tconstr (p, _, _) when Path.same p Predef.path_unit -> ()
-- | Tvar when ty.level > tv.level ->
-+ | Tvar _ when ty.level > tv.level ->
- Location.prerr_warning loc Warnings.Nonreturning_statement
-- | Tvar ->
-+ | Tvar _ ->
- add_delayed_check (fun () -> check_application_result env true exp)
- | _ ->
- Location.prerr_warning loc Warnings.Statement_type
-Index: typing/btype.mli
-===================================================================
---- typing/btype.mli (リビジョン 11207)
-+++ typing/btype.mli (作æ¥ã‚³ãƒ”ー)
-@@ -23,7 +23,7 @@
- (* Create a type *)
- val newgenty: type_desc -> type_expr
- (* Create a generic type *)
--val newgenvar: unit -> type_expr
-+val newgenvar: ?name:string -> unit -> type_expr
- (* Return a fresh generic variable *)
-
- (* Use Tsubst instead
-@@ -33,6 +33,9 @@
- (* Return a fresh marked generic variable *)
- *)
-
-+val is_Tvar: type_expr -> bool
-+val is_Tunivar: type_expr -> bool
-+
- val repr: type_expr -> type_expr
- (* Return the canonical representative of a type. *)
-
-Index: typing/ctype.mli
-===================================================================
---- typing/ctype.mli (リビジョン 11207)
-+++ typing/ctype.mli (作æ¥ã‚³ãƒ”ー)
-@@ -41,9 +41,10 @@
- (* This pair of functions is only used in Typetexp *)
-
- val newty: type_desc -> type_expr
--val newvar: unit -> type_expr
-+val newvar: ?name:string -> unit -> type_expr
-+val newvar2: ?name:string -> int -> type_expr
- (* Return a fresh variable *)
--val new_global_var: unit -> type_expr
-+val new_global_var: ?name:string -> unit -> type_expr
- (* Return a fresh variable, bound at toplevel
- (as type variables ['a] in type constraints). *)
- val newobj: type_expr -> type_expr
-Index: typing/datarepr.ml
-===================================================================
---- typing/datarepr.ml (リビジョン 11207)
-+++ typing/datarepr.ml (作æ¥ã‚³ãƒ”ー)
-@@ -28,7 +28,7 @@
- if ty.level >= lowest_level then begin
- ty.level <- pivot_level - ty.level;
- match ty.desc with
-- | Tvar ->
-+ | Tvar _ ->
- ret := TypeSet.add ty !ret
- | Tvariant row ->
- let row = row_repr row in
-Index: typing/typeclass.ml
-===================================================================
---- typing/typeclass.ml (リビジョン 11207)
-+++ typing/typeclass.ml (作æ¥ã‚³ãƒ”ー)
-@@ -532,7 +532,7 @@
- (Typetexp.transl_simple_type val_env false sty) ty
- end;
- begin match (Ctype.repr ty).desc with
-- Tvar ->
-+ Tvar _ ->
- let ty' = Ctype.newvar () in
- Ctype.unify val_env (Ctype.newty (Tpoly (ty', []))) ty;
- Ctype.unify val_env (type_approx val_env sbody) ty'
-Index: typing/typedecl.ml
-===================================================================
---- typing/typedecl.ml (リビジョン 11207)
-+++ typing/typedecl.ml (作æ¥ã‚³ãƒ”ー)
-@@ -111,7 +111,7 @@
- | _ ->
- raise (Error (loc, Bad_fixed_type "is not an object or variant"))
- in
-- if rv.desc <> Tvar then
-+ if not (Btype.is_Tvar rv) then
- raise (Error (loc, Bad_fixed_type "has no row variable"));
- rv.desc <- Tconstr (p, decl.type_params, ref Mnil)
-
-@@ -503,7 +503,7 @@
- compute_same row.row_more
- | Tpoly (ty, _) ->
- compute_same ty
-- | Tvar | Tnil | Tlink _ | Tunivar -> ()
-+ | Tvar _ | Tnil | Tlink _ | Tunivar _ -> ()
- | Tpackage (_, _, tyl) ->
- List.iter (compute_variance_rec true true true) tyl
- end
-@@ -546,7 +546,7 @@
- in
- List.iter2
- (fun (ty, co, cn, ct) (c, n) ->
-- if ty.desc <> Tvar then begin
-+ if not (Btype.is_Tvar ty) then begin
- co := c; cn := n; ct := n;
- compute_variance env tvl2 c n n ty
- end)
-@@ -571,7 +571,7 @@
-
- let rec anonymous env ty =
- match (Ctype.expand_head env ty).desc with
-- | Tvar -> false
-+ | Tvar _ -> false
- | Tobject (fi, _) ->
- let _, rv = Ctype.flatten_fields fi in anonymous env rv
- | Tvariant row ->
-Index: typing/types.mli
-===================================================================
---- typing/types.mli (リビジョン 11207)
-+++ typing/types.mli (作æ¥ã‚³ãƒ”ー)
-@@ -24,7 +24,7 @@
- mutable id: int }
-
- and type_desc =
-- Tvar
-+ Tvar of string option
- | Tarrow of label * type_expr * type_expr * commutable
- | Ttuple of type_expr list
- | Tconstr of Path.t * type_expr list * abbrev_memo ref
-@@ -34,7 +34,7 @@
- | Tlink of type_expr
- | Tsubst of type_expr (* for copying *)
- | Tvariant of row_desc
-- | Tunivar
-+ | Tunivar of string option
- | Tpoly of type_expr * type_expr list
- | Tpackage of Path.t * string list * type_expr list
-
-Index: typing/ctype.ml
-===================================================================
---- typing/ctype.ml (リビジョン 11207)
-+++ typing/ctype.ml (作æ¥ã‚³ãƒ”ー)
-@@ -153,9 +153,9 @@
- let newty desc = newty2 !current_level desc
- let new_global_ty desc = newty2 !global_level desc
-
--let newvar () = newty2 !current_level Tvar
--let newvar2 level = newty2 level Tvar
--let new_global_var () = newty2 !global_level Tvar
-+let newvar ?name () = newty2 !current_level (Tvar name)
-+let newvar2 ?name level = newty2 level (Tvar name)
-+let new_global_var ?name () = newty2 !global_level (Tvar name)
-
- let newobj fields = newty (Tobject (fields, ref None))
-
-@@ -297,14 +297,12 @@
-
- let opened_object ty =
- match (object_row ty).desc with
-- | Tvar -> true
-- | Tunivar -> true
-- | Tconstr _ -> true
-- | _ -> false
-+ | Tvar _ | Tunivar _ | Tconstr _ -> true
-+ | _ -> false
-
- let concrete_object ty =
- match (object_row ty).desc with
-- | Tvar -> false
-+ | Tvar _ -> false
- | _ -> true
-
- (**** Close an object ****)
-@@ -313,7 +311,7 @@
- let rec close ty =
- let ty = repr ty in
- match ty.desc with
-- Tvar ->
-+ Tvar _ ->
- link_type ty (newty2 ty.level Tnil)
- | Tfield(_, _, _, ty') -> close ty'
- | _ -> assert false
-@@ -329,7 +327,7 @@
- let ty = repr ty in
- match ty.desc with
- Tfield (_, _, _, ty) -> find ty
-- | Tvar -> ty
-+ | Tvar _ -> ty
- | _ -> assert false
- in
- match (repr ty).desc with
-@@ -434,7 +432,7 @@
- let level = ty.level in
- ty.level <- pivot_level - level;
- match ty.desc with
-- Tvar when level <> generic_level ->
-+ Tvar _ when level <> generic_level ->
- raise Non_closed
- | Tfield(_, kind, t1, t2) ->
- if field_kind_repr kind = Fpresent then
-@@ -468,7 +466,7 @@
- if ty.level >= lowest_level then begin
- ty.level <- pivot_level - ty.level;
- begin match ty.desc, !really_closed with
-- Tvar, _ ->
-+ Tvar _, _ ->
- free_variables := (ty, real) :: !free_variables
- | Tconstr (path, tl, _), Some env ->
- begin try
-@@ -639,7 +637,7 @@
- let rec generalize_structure var_level ty =
- let ty = repr ty in
- if ty.level <> generic_level then begin
-- if ty.desc = Tvar && ty.level > var_level then
-+ if is_Tvar ty && ty.level > var_level then
- set_level ty var_level
- else if ty.level > !current_level then begin
- set_level ty generic_level;
-@@ -858,7 +856,7 @@
- TypeHash.add node_univars inv.inv_type (ref(TypeSet.singleton univ));
- List.iter (add_univar univ) inv.inv_parents
- in
-- TypeHash.iter (fun ty inv -> if ty.desc = Tunivar then add_univar ty inv)
-+ TypeHash.iter (fun ty inv -> if is_Tunivar ty then add_univar ty inv)
- inverted;
- fun ty ->
- try !(TypeHash.find node_univars ty) with Not_found -> TypeSet.empty
-@@ -913,7 +911,7 @@
- if keep then ty.level else !current_level
- else generic_level
- in
-- if forget <> generic_level then newty2 forget Tvar else
-+ if forget <> generic_level then newty2 forget (Tvar None) else
- let desc = ty.desc in
- save_desc ty desc;
- let t = newvar() in (* Stub *)
-@@ -959,7 +957,7 @@
- | Tconstr _ ->
- if keep then save_desc more more.desc;
- copy more
-- | Tvar | Tunivar ->
-+ | Tvar _ | Tunivar _ ->
- save_desc more more.desc;
- if keep then more else newty more.desc
- | _ -> assert false
-@@ -1117,7 +1115,7 @@
- t
- else try
- let t, bound_t = List.assq ty visited in
-- let dl = if ty.desc = Tunivar then [] else diff_list bound bound_t in
-+ let dl = if is_Tunivar ty then [] else diff_list bound bound_t in
- if dl <> [] && conflicts univars dl then raise Not_found;
- t
- with Not_found -> begin
-@@ -1134,14 +1132,14 @@
- let row = row_repr row0 in
- let more = repr row.row_more in
- (* We shall really check the level on the row variable *)
-- let keep = more.desc = Tvar && more.level <> generic_level in
-+ let keep = is_Tvar more && more.level <> generic_level in
- let more' = copy_rec more in
-- let fixed' = fixed && (repr more').desc = Tvar in
-+ let fixed' = fixed && is_Tvar (repr more') in
- let row = copy_row copy_rec fixed' row keep more' in
- Tvariant row
- | Tpoly (t1, tl) ->
- let tl = List.map repr tl in
-- let tl' = List.map (fun t -> newty Tunivar) tl in
-+ let tl' = List.map (fun t -> newty t.desc) tl in
- let bound = tl @ bound in
- let visited =
- List.map2 (fun ty t -> ty,(t,bound)) tl tl' @ visited in
-@@ -1395,7 +1393,7 @@
- let rec full_expand env ty =
- let ty = repr (expand_head env ty) in
- match ty.desc with
-- Tobject (fi, {contents = Some (_, v::_)}) when (repr v).desc = Tvar ->
-+ Tobject (fi, {contents = Some (_, v::_)}) when is_Tvar (repr v) ->
- newty2 ty.level (Tobject (fi, ref None))
- | _ ->
- ty
-@@ -1570,8 +1568,8 @@
- true
- then
- match ty.desc with
-- Tunivar ->
-- if not (TypeSet.mem ty bound) then raise (Unify [ty, newgenvar()])
-+ Tunivar _ ->
-+ if not (TypeSet.mem ty bound) then raise (Unify [ty, newgenvar ()])
- | Tpoly (ty, tyl) ->
- let bound = List.fold_right TypeSet.add (List.map repr tyl) bound in
- occur_rec bound ty
-@@ -1620,7 +1618,7 @@
- Tpoly (t, tl) ->
- if List.exists (fun t -> TypeSet.mem (repr t) family) tl then ()
- else occur t
-- | Tunivar ->
-+ | Tunivar _ ->
- if TypeSet.mem t family then raise Occur
- | Tconstr (_, [], _) -> ()
- | Tconstr (p, tl, _) ->
-@@ -1784,7 +1782,7 @@
- t
- end;
- iter_type_expr (iterator visited) ty
-- | Tvar ->
-+ | Tvar _ ->
- let t = create_fresh_constr ty.level false in
- link_type ty t
- | _ ->
-@@ -1862,8 +1860,8 @@
- let t2 = repr t2 in
- if t1 == t2 then () else
- match (t1.desc, t2.desc) with
-- | (Tvar, _)
-- | (_, Tvar) ->
-+ | (Tvar _, _)
-+ | (_, Tvar _) ->
- fatal_error "types should not include variables"
- | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
- ()
-@@ -1877,7 +1875,7 @@
- with Not_found ->
- TypePairs.add type_pairs (t1', t2') ();
- match (t1'.desc, t2'.desc) with
-- (Tvar, Tvar) ->
-+ (Tvar _, Tvar _) ->
- fatal_error "types should not include variables"
- | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2
- || !Clflags.classic && not (is_optional l1 || is_optional l2) ->
-@@ -1903,7 +1901,7 @@
- | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
- enter_poly env univar_pairs t1 tl1 t2 tl2
- (mcomp type_pairs subst env)
-- | (Tunivar, Tunivar) ->
-+ | (Tunivar _, Tunivar _) ->
- unify_univar t1' t2' !univar_pairs
- | (_, _) ->
- raise (Unify [])
-@@ -2048,21 +2046,21 @@
- try
- type_changed := true;
- match (t1.desc, t2.desc) with
-- (Tvar, Tconstr _) when deep_occur t1 t2 ->
-+ (Tvar _, Tconstr _) when deep_occur t1 t2 ->
- unify2 env t1 t2
-- | (Tconstr _, Tvar) when deep_occur t2 t1 ->
-+ | (Tconstr _, Tvar _) when deep_occur t2 t1 ->
- unify2 env t1 t2
-- | (Tvar, _) ->
-+ | (Tvar _, _) ->
- occur !env t1 t2;
- occur_univar !env t2;
- link_type t1 t2;
- update_level !env t1.level t2
-- | (_, Tvar) ->
-+ | (_, Tvar _) ->
- occur !env t2 t1;
- occur_univar !env t1;
- link_type t2 t1;
- update_level !env t2.level t1
-- | (Tunivar, Tunivar) ->
-+ | (Tunivar _, Tunivar _) ->
- unify_univar t1 t2 !univar_pairs;
- update_level !env t1.level t2;
- link_type t1 t2
-@@ -2104,7 +2102,7 @@
- (* Assumes either [t1 == t1'] or [t2 != t2'] *)
- let d1 = t1'.desc and d2 = t2'.desc in
- match (d1, d2) with (* handle univars specially *)
-- (Tunivar, Tunivar) ->
-+ (Tunivar _, Tunivar _) ->
- unify_univar t1' t2' !univar_pairs;
- update_level !env t1'.level t2';
- link_type t1' t2'
-@@ -2127,12 +2125,12 @@
- | Old -> f () (* old_link was already called *)
- in
- match d1, d2 with
-- | Tvar,_ ->
-+ | Tvar _, _ ->
- occur !env t1 t2';
- occur_univar !env t2;
- update_level !env t1'.level t2;
- link_type t1' t2;
-- | _, Tvar ->
-+ | _, Tvar _ ->
- occur !env t2 t1';
- occur_univar !env t1;
- update_level !env t2'.level t1;
-@@ -2149,8 +2147,8 @@
- add_type_equality t1' t2' end;
- try
- begin match (d1, d2) with
-- | (Tvar, _)
-- | (_, Tvar) ->
-+ | (Tvar _, _)
-+ | (_, Tvar _) ->
- (* cases taken care of *)
- assert false
- | (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when l1 = l2
-@@ -2214,8 +2212,9 @@
- (* Type [t2'] may have been instantiated by [unify_fields] *)
- (* XXX One should do some kind of unification... *)
- begin match (repr t2').desc with
-- Tobject (_, {contents = Some (_, va::_)})
-- when let va = repr va in List.mem va.desc [Tvar; Tunivar; Tnil] ->
-+ Tobject (_, {contents = Some (_, va::_)}) when
-+ (match (repr va).desc with
-+ Tvar _|Tunivar _|Tnil -> true | _ -> false) ->
- ()
- | Tobject (_, nm2) ->
- set_name nm2 !nm1
-@@ -2290,16 +2289,32 @@
- raise (Unify []);
- List.iter2 (unify env) tl1 tl2
-
-+(* Build a fresh row variable for unification *)
-+and make_rowvar level use1 rest1 use2 rest2 =
-+ let set_name ty name =
-+ match ty.desc with
-+ Tvar None -> log_type ty; ty.desc <- Tvar name
-+ | _ -> ()
-+ in
-+ let name =
-+ match rest1.desc, rest2.desc with
-+ Tvar (Some _ as name1), Tvar (Some _ as name2) ->
-+ if rest1.level <= rest2.level then name1 else name2
-+ | Tvar (Some _ as name), _ ->
-+ if use2 then set_name rest2 name; name
-+ | _, Tvar (Some _ as name) ->
-+ if use1 then set_name rest2 name; name
-+ | _ -> None
-+ in
-+ if use1 then rest1 else
-+ if use2 then rest2 else newvar2 ?name level
-+
- and unify_fields env ty1 ty2 = (* Optimization *)
- let (fields1, rest1) = flatten_fields ty1
- and (fields2, rest2) = flatten_fields ty2 in
- let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
- let l1 = (repr ty1).level and l2 = (repr ty2).level in
-- let va =
-- if miss1 = [] then rest2
-- else if miss2 = [] then rest1
-- else newty2 (min l1 l2) Tvar
-- in
-+ let va = make_rowvar (min l1 l2) (miss2=[]) rest1 (miss1=[]) rest2 in
- let d1 = rest1.desc and d2 = rest2.desc in
- try
- unify env (build_fields l1 miss1 va) rest2;
-@@ -2390,7 +2405,7 @@
- let rm = row_more row in
- if row.row_fixed then
- if row0.row_more == rm then () else
-- if rm.desc = Tvar then link_type rm row0.row_more else
-+ if is_Tvar rm then link_type rm row0.row_more else
- unify env rm row0.row_more
- else
- let ty = newty2 generic_level (Tvariant {row0 with row_fields = rest}) in
-@@ -2489,7 +2504,7 @@
- let t1 = repr t1 and t2 = repr t2 in
- if t1 == t2 then () else
- match t1.desc with
-- Tvar ->
-+ Tvar _ ->
- begin try
- occur env t1 t2;
- update_level env t1.level t2;
-@@ -2527,7 +2542,7 @@
- let rec filter_arrow env t l =
- let t = expand_head_unif env t in
- match t.desc with
-- Tvar ->
-+ Tvar _ ->
- let lv = t.level in
- let t1 = newvar2 lv and t2 = newvar2 lv in
- let t' = newty2 lv (Tarrow (l, t1, t2, Cok)) in
-@@ -2543,7 +2558,7 @@
- let rec filter_method_field env name priv ty =
- let ty = repr ty in
- match ty.desc with
-- Tvar ->
-+ Tvar _ ->
- let level = ty.level in
- let ty1 = newvar2 level and ty2 = newvar2 level in
- let ty' = newty2 level (Tfield (name,
-@@ -2570,7 +2585,7 @@
- let rec filter_method env name priv ty =
- let ty = expand_head_unif env ty in
- match ty.desc with
-- Tvar ->
-+ Tvar _ ->
- let ty1 = newvar () in
- let ty' = newobj ty1 in
- update_level env ty.level ty';
-@@ -2606,7 +2621,7 @@
- let rec occur ty =
- let ty = repr ty in
- if ty.level > level then begin
-- if ty.desc = Tvar && ty.level >= generic_level - 1 then raise Occur;
-+ if is_Tvar ty && ty.level >= generic_level - 1 then raise Occur;
- ty.level <- pivot_level - ty.level;
- match ty.desc with
- Tvariant row when static_row row ->
-@@ -2636,7 +2651,7 @@
-
- try
- match (t1.desc, t2.desc) with
-- (Tvar, _) when may_instantiate inst_nongen t1 ->
-+ (Tvar _, _) when may_instantiate inst_nongen t1 ->
- moregen_occur env t1.level t2;
- occur env t1 t2;
- link_type t1 t2
-@@ -2653,7 +2668,7 @@
- with Not_found ->
- TypePairs.add type_pairs (t1', t2') ();
- match (t1'.desc, t2'.desc) with
-- (Tvar, _) when may_instantiate inst_nongen t1' ->
-+ (Tvar _, _) when may_instantiate inst_nongen t1' ->
- moregen_occur env t1'.level t2;
- link_type t1' t2
- | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2
-@@ -2684,7 +2699,7 @@
- | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
- enter_poly env univar_pairs t1 tl1 t2 tl2
- (moregen inst_nongen type_pairs env)
-- | (Tunivar, Tunivar) ->
-+ | (Tunivar _, Tunivar _) ->
- unify_univar t1' t2' !univar_pairs
- | (_, _) ->
- raise (Unify [])
-@@ -2725,7 +2740,7 @@
- let row1 = row_repr row1 and row2 = row_repr row2 in
- let rm1 = repr row1.row_more and rm2 = repr row2.row_more in
- if rm1 == rm2 then () else
-- let may_inst = rm1.desc = Tvar && may_instantiate inst_nongen rm1 in
-+ let may_inst = is_Tvar rm1 && may_instantiate inst_nongen rm1 in
- let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
- let r1, r2 =
- if row2.row_closed then
-@@ -2735,9 +2750,9 @@
- if r1 <> [] || row1.row_closed && (not row2.row_closed || r2 <> [])
- then raise (Unify []);
- begin match rm1.desc, rm2.desc with
-- Tunivar, Tunivar ->
-+ Tunivar _, Tunivar _ ->
- unify_univar rm1 rm2 !univar_pairs
-- | Tunivar, _ | _, Tunivar ->
-+ | Tunivar _, _ | _, Tunivar _ ->
- raise (Unify [])
- | _ when static_row row1 -> ()
- | _ when may_inst ->
-@@ -2828,13 +2843,13 @@
- if ty.level >= lowest_level then begin
- ty.level <- pivot_level - ty.level;
- match ty.desc with
-- | Tvar ->
-+ | Tvar _ ->
- if not (List.memq ty !vars) then vars := ty :: !vars
- | Tvariant row ->
- let row = row_repr row in
- let more = repr row.row_more in
-- if more.desc = Tvar && not row.row_fixed then begin
-- let more' = newty2 more.level Tvar in
-+ if is_Tvar more && not row.row_fixed then begin
-+ let more' = newty2 more.level more.desc in
- let row' = {row with row_fixed=true; row_fields=[]; row_more=more'}
- in link_type more (newty2 ty.level (Tvariant row'))
- end;
-@@ -2857,7 +2872,7 @@
- (fun ty ->
- let ty = expand_head env ty in
- if List.memq ty !tyl then false else
-- (tyl := ty :: !tyl; ty.desc = Tvar))
-+ (tyl := ty :: !tyl; is_Tvar ty))
- vars
-
- let matches env ty ty' =
-@@ -2901,7 +2916,7 @@
-
- try
- match (t1.desc, t2.desc) with
-- (Tvar, Tvar) when rename ->
-+ (Tvar _, Tvar _) when rename ->
- begin try
- normalize_subst subst;
- if List.assq t1 !subst != t2 then raise (Unify [])
-@@ -2922,7 +2937,7 @@
- with Not_found ->
- TypePairs.add type_pairs (t1', t2') ();
- match (t1'.desc, t2'.desc) with
-- (Tvar, Tvar) when rename ->
-+ (Tvar _, Tvar _) when rename ->
- begin try
- normalize_subst subst;
- if List.assq t1' !subst != t2' then raise (Unify [])
-@@ -2956,7 +2971,7 @@
- | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
- enter_poly env univar_pairs t1 tl1 t2 tl2
- (eqtype rename type_pairs subst env)
-- | (Tunivar, Tunivar) ->
-+ | (Tunivar _, Tunivar _) ->
- unify_univar t1' t2' !univar_pairs
- | (_, _) ->
- raise (Unify [])
-@@ -3405,7 +3420,7 @@
- let rec build_subtype env visited loops posi level t =
- let t = repr t in
- match t.desc with
-- Tvar ->
-+ Tvar _ ->
- if posi then
- try
- let t' = List.assq t loops in
-@@ -3454,13 +3469,13 @@
- as this occurence might break the occur check.
- XXX not clear whether this correct anyway... *)
- if List.exists (deep_occur ty) tl1 then raise Not_found;
-- ty.desc <- Tvar;
-+ ty.desc <- Tvar None;
- let t'' = newvar () in
- let loops = (ty, t'') :: loops in
- (* May discard [visited] as level is going down *)
- let (ty1', c) =
- build_subtype env [t'] loops posi (pred_enlarge level') ty1 in
-- assert (t''.desc = Tvar);
-+ assert (is_Tvar t'');
- let nm =
- if c > Equiv || deep_occur ty ty1' then None else Some(p,tl1) in
- t''.desc <- Tobject (ty1', ref nm);
-@@ -3559,7 +3574,7 @@
- let (t1', c) = build_subtype env visited loops posi level t1 in
- if c > Unchanged then (newty (Tpoly(t1', tl)), c)
- else (t, Unchanged)
-- | Tunivar | Tpackage _ ->
-+ | Tunivar _ | Tpackage _ ->
- (t, Unchanged)
-
- let enlarge_type env ty =
-@@ -3623,7 +3638,7 @@
- with Not_found ->
- TypePairs.add subtypes (t1, t2) ();
- match (t1.desc, t2.desc) with
-- (Tvar, _) | (_, Tvar) ->
-+ (Tvar _, _) | (_, Tvar _) ->
- (trace, t1, t2, !univar_pairs)::cstrs
- | (Tarrow(l1, t1, u1, _), Tarrow(l2, t2, u2, _)) when l1 = l2
- || !Clflags.classic && not (is_optional l1 || is_optional l2) ->
-@@ -3659,7 +3674,7 @@
- | (Tconstr(p1, tl1, _), _) when private_abbrev env p1 ->
- subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs
- | (Tobject (f1, _), Tobject (f2, _))
-- when (object_row f1).desc = Tvar && (object_row f2).desc = Tvar ->
-+ when is_Tvar (object_row f1) && is_Tvar (object_row f2) ->
- (* Same row variable implies same object. *)
- (trace, t1, t2, !univar_pairs)::cstrs
- | (Tobject (f1, _), Tobject (f2, _)) ->
-@@ -3731,7 +3746,7 @@
- match more1.desc, more2.desc with
- Tconstr(p1,_,_), Tconstr(p2,_,_) when Path.same p1 p2 ->
- subtype_rec env ((more1,more2)::trace) more1 more2 cstrs
-- | (Tvar|Tconstr _), (Tvar|Tconstr _)
-+ | (Tvar _|Tconstr _), (Tvar _|Tconstr _)
- when row1.row_closed && r1 = [] ->
- List.fold_left
- (fun cstrs (_,f1,f2) ->
-@@ -3745,7 +3760,7 @@
- | Rabsent, _ -> cstrs
- | _ -> raise Exit)
- cstrs pairs
-- | Tunivar, Tunivar
-+ | Tunivar _, Tunivar _
- when row1.row_closed = row2.row_closed && r1 = [] && r2 = [] ->
- let cstrs =
- subtype_rec env ((more1,more2)::trace) more1 more2 cstrs in
-@@ -3789,19 +3804,19 @@
- match ty.desc with
- Tfield (s, k, t1, t2) ->
- newty2 ty.level (Tfield (s, k, t1, unalias_object t2))
-- | Tvar | Tnil ->
-+ | Tvar _ | Tnil ->
- newty2 ty.level ty.desc
-- | Tunivar ->
-+ | Tunivar _ ->
- ty
- | Tconstr _ ->
-- newty2 ty.level Tvar
-+ newvar2 ty.level
- | _ ->
- assert false
-
- let unalias ty =
- let ty = repr ty in
- match ty.desc with
-- Tvar | Tunivar ->
-+ Tvar _ | Tunivar _ ->
- ty
- | Tvariant row ->
- let row = row_repr row in
-@@ -3875,7 +3890,7 @@
- set_name nm None
- else let v' = repr v in
- begin match v'.desc with
-- | Tvar|Tunivar ->
-+ | Tvar _ | Tunivar _ ->
- if v' != v then set_name nm (Some (n, v' :: l))
- | Tnil ->
- log_type ty; ty.desc <- Tconstr (n, l, ref Mnil)
-@@ -3917,7 +3932,7 @@
-
- let rec nondep_type_rec env id ty =
- match ty.desc with
-- Tvar | Tunivar -> ty
-+ Tvar _ | Tunivar _ -> ty
- | Tlink ty -> nondep_type_rec env id ty
- | _ -> try TypeHash.find nondep_hash ty
- with Not_found ->
-@@ -3987,7 +4002,7 @@
-
- let unroll_abbrev id tl ty =
- let ty = repr ty and path = Path.Pident id in
-- if (ty.desc = Tvar) || (List.exists (deep_occur ty) tl)
-+ if is_Tvar ty || (List.exists (deep_occur ty) tl)
- || is_object_type path then
- ty
- else
-Index: typing/printtyp.ml
-===================================================================
---- typing/printtyp.ml (リビジョン 11207)
-+++ typing/printtyp.ml (作æ¥ã‚³ãƒ”ー)
-@@ -109,6 +109,10 @@
- | Mcons (priv, p, t1, t2, rem) -> p :: list_of_memo rem
- | Mlink rem -> list_of_memo !rem
-
-+let print_name ppf = function
-+ None -> fprintf ppf "None"
-+ | Some name -> fprintf ppf "\"%s\"" name
-+
- let visited = ref []
- let rec raw_type ppf ty =
- let ty = safe_repr [] ty in
-@@ -119,7 +123,7 @@
- end
- and raw_type_list tl = raw_list raw_type tl
- and raw_type_desc ppf = function
-- Tvar -> fprintf ppf "Tvar"
-+ Tvar name -> fprintf ppf "Tvar %a" print_name name
- | Tarrow(l,t1,t2,c) ->
- fprintf ppf "@[<hov1>Tarrow(%s,@,%a,@,%a,@,%s)@]"
- l raw_type t1 raw_type t2
-@@ -143,7 +147,7 @@
- | Tnil -> fprintf ppf "Tnil"
- | Tlink t -> fprintf ppf "@[<1>Tlink@,%a@]" raw_type t
- | Tsubst t -> fprintf ppf "@[<1>Tsubst@,%a@]" raw_type t
-- | Tunivar -> fprintf ppf "Tunivar"
-+ | Tunivar name -> fprintf ppf "Tunivar %a" print_name name
- | Tpoly (t, tl) ->
- fprintf ppf "@[<hov1>Tpoly(@,%a,@,%a)@]"
- raw_type t
-@@ -189,28 +193,61 @@
-
- let names = ref ([] : (type_expr * string) list)
- let name_counter = ref 0
-+let named_vars = ref ([] : string list)
-
--let reset_names () = names := []; name_counter := 0
-+let reset_names () = names := []; name_counter := 0; named_vars := []
-+let add_named_var ty =
-+ match ty.desc with
-+ Tvar (Some name) | Tunivar (Some name) ->
-+ if List.mem name !named_vars then () else
-+ named_vars := name :: !named_vars
-+ | _ -> ()
-
--let new_name () =
-+let rec new_name () =
- let name =
- if !name_counter < 26
- then String.make 1 (Char.chr(97 + !name_counter))
- else String.make 1 (Char.chr(97 + !name_counter mod 26)) ^
- string_of_int(!name_counter / 26) in
- incr name_counter;
-- name
-+ if List.mem name !named_vars
-+ || List.exists (fun (_, name') -> name = name') !names
-+ then new_name ()
-+ else name
-
- let name_of_type t =
-+ (* We've already been through repr at this stage, so t is our representative
-+ of the union-find class. *)
- try List.assq t !names with Not_found ->
-- let name = new_name () in
-+ let name =
-+ match t.desc with
-+ Tvar (Some name) | Tunivar (Some name) ->
-+ (* Some part of the type we've already printed has assigned another
-+ * unification variable to that name. We want to keep the name, so try
-+ * adding a number until we find a name that's not taken. *)
-+ let current_name = ref name in
-+ let i = ref 0 in
-+ while List.exists (fun (_, name') -> !current_name = name') !names do
-+ current_name := name ^ (string_of_int !i);
-+ i := !i + 1;
-+ done;
-+ !current_name
-+ | _ ->
-+ (* No name available, create a new one *)
-+ new_name ()
-+ in
- names := (t, name) :: !names;
- name
-
- let check_name_of_type t = ignore(name_of_type t)
-
-+let remove_names tyl =
-+ let tyl = List.map repr tyl in
-+ names := List.filter (fun (ty,_) -> not (List.memq ty tyl)) !names
-+
-+
- let non_gen_mark sch ty =
-- if sch && ty.desc = Tvar && ty.level <> generic_level then "_" else ""
-+ if sch && is_Tvar ty && ty.level <> generic_level then "_" else ""
-
- let print_name_of_type sch ppf t =
- fprintf ppf "'%s%s" (non_gen_mark sch t) (name_of_type t)
-@@ -225,9 +262,13 @@
- let is_aliased ty = List.memq (proxy ty) !aliased
- let add_alias ty =
- let px = proxy ty in
-- if not (is_aliased px) then aliased := px :: !aliased
-+ if not (is_aliased px) then begin
-+ aliased := px :: !aliased;
-+ add_named_var px
-+ end
-+
- let aliasable ty =
-- match ty.desc with Tvar | Tunivar | Tpoly _ -> false | _ -> true
-+ match ty.desc with Tvar _ | Tunivar _ | Tpoly _ -> false | _ -> true
-
- let namable_row row =
- row.row_name <> None &&
-@@ -245,7 +286,7 @@
- if List.memq px visited && aliasable ty then add_alias px else
- let visited = px :: visited in
- match ty.desc with
-- | Tvar -> ()
-+ | Tvar _ -> add_named_var ty
- | Tarrow(_, ty1, ty2, _) ->
- mark_loops_rec visited ty1; mark_loops_rec visited ty2
- | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl
-@@ -290,7 +331,7 @@
- | Tpoly (ty, tyl) ->
- List.iter (fun t -> add_alias t) tyl;
- mark_loops_rec visited ty
-- | Tunivar -> ()
-+ | Tunivar _ -> add_named_var ty
-
- let mark_loops ty =
- normalize_type Env.empty ty;
-@@ -322,7 +363,7 @@
-
- let pr_typ () =
- match ty.desc with
-- | Tvar ->
-+ | Tvar _ ->
- Otyp_var (is_non_gen sch ty, name_of_type ty)
- | Tarrow(l, ty1, ty2, _) ->
- let pr_arrow l ty1 ty2 =
-@@ -387,16 +428,22 @@
- | Tpoly (ty, []) ->
- tree_of_typexp sch ty
- | Tpoly (ty, tyl) ->
-+ (*let print_names () =
-+ List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names;
-+ prerr_string "; " in *)
- let tyl = List.map repr tyl in
-- (* let tyl = List.filter is_aliased tyl in *)
- if tyl = [] then tree_of_typexp sch ty else begin
- let old_delayed = !delayed in
-+ (* Make the names delayed, so that the real type is
-+ printed once when used as proxy *)
- List.iter add_delayed tyl;
- let tl = List.map name_of_type tyl in
- let tr = Otyp_poly (tl, tree_of_typexp sch ty) in
-+ (* Forget names when we leave scope *)
-+ remove_names tyl;
- delayed := old_delayed; tr
- end
-- | Tunivar ->
-+ | Tunivar _ ->
- Otyp_var (false, name_of_type ty)
- | Tpackage (p, n, tyl) ->
- Otyp_module (Path.name p, n, tree_of_typlist sch tyl)
-@@ -446,13 +493,13 @@
- end
-
- and is_non_gen sch ty =
-- sch && ty.desc = Tvar && ty.level <> generic_level
-+ sch && is_Tvar ty && ty.level <> generic_level
-
- and tree_of_typfields sch rest = function
- | [] ->
- let rest =
- match rest.desc with
-- | Tvar | Tunivar -> Some (is_non_gen sch rest)
-+ | Tvar _ | Tunivar _ -> Some (is_non_gen sch rest)
- | Tconstr _ -> Some false
- | Tnil -> None
- | _ -> fatal_error "typfields (1)"
-@@ -564,7 +611,7 @@
- let vari =
- List.map2
- (fun ty (co,cn,ct) ->
-- if abstr || (repr ty).desc <> Tvar then (co,cn) else (true,true))
-+ if abstr || not (is_Tvar (repr ty)) then (co,cn) else (true,true))
- decl.type_params decl.type_variance
- in
- (Ident.name id,
-@@ -645,16 +692,18 @@
-
- let method_type (_, kind, ty) =
- match field_kind_repr kind, repr ty with
-- Fpresent, {desc=Tpoly(ty, _)} -> ty
-- | _ , ty -> ty
-+ Fpresent, {desc=Tpoly(ty, tyl)} -> (ty, tyl)
-+ | _ , ty -> (ty, [])
-
- let tree_of_metho sch concrete csil (lab, kind, ty) =
- if lab <> dummy_method then begin
- let kind = field_kind_repr kind in
- let priv = kind <> Fpresent in
- let virt = not (Concr.mem lab concrete) in
-- let ty = method_type (lab, kind, ty) in
-- Ocsg_method (lab, priv, virt, tree_of_typexp sch ty) :: csil
-+ let (ty, tyl) = method_type (lab, kind, ty) in
-+ let tty = tree_of_typexp sch ty in
-+ remove_names tyl;
-+ Ocsg_method (lab, priv, virt, tty) :: csil
- end
- else csil
-
-@@ -662,7 +711,7 @@
- | Tcty_constr (p, tyl, cty) ->
- let sty = Ctype.self_type cty in
- if List.memq (proxy sty) !visited_objects
-- || List.exists (fun ty -> (repr ty).desc <> Tvar) params
-+ || not (List.for_all is_Tvar params)
- || List.exists (deep_occur sty) tyl
- then prepare_class_type params cty
- else List.iter mark_loops tyl
-@@ -675,7 +724,7 @@
- let (fields, _) =
- Ctype.flatten_fields (Ctype.object_fields sign.cty_self)
- in
-- List.iter (fun met -> mark_loops (method_type met)) fields;
-+ List.iter (fun met -> mark_loops (fst (method_type met))) fields;
- Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.cty_vars
- | Tcty_fun (_, ty, cty) ->
- mark_loops ty;
-@@ -686,7 +735,7 @@
- | Tcty_constr (p', tyl, cty) ->
- let sty = Ctype.self_type cty in
- if List.memq (proxy sty) !visited_objects
-- || List.exists (fun ty -> (repr ty).desc <> Tvar) params
-+ || not (List.for_all is_Tvar params)
- then
- tree_of_class_type sch params cty
- else
-@@ -743,7 +792,7 @@
- (match tree_of_typexp true param with
- Otyp_var (_, s) -> s
- | _ -> "?"),
-- if (repr param).desc = Tvar then (true, true) else variance
-+ if is_Tvar (repr param) then (true, true) else variance
-
- let tree_of_class_params params =
- let tyl = tree_of_typlist true params in
-@@ -890,7 +939,7 @@
- | {desc = Tvariant row} as t when (row_repr row).row_name <> None ->
- newty2 t.level
- (Tvariant {(row_repr row) with row_name = None;
-- row_more = newty2 (row_more row).level Tvar})
-+ row_more = newvar2 (row_more row).level})
- | _ -> t
-
- let prepare_expansion (t, t') =
-@@ -913,9 +962,9 @@
- let has_explanation unif t3 t4 =
- match t3.desc, t4.desc with
- Tfield _, _ | _, Tfield _
-- | Tunivar, Tvar | Tvar, Tunivar
-+ | Tunivar _, Tvar _ | Tvar _, Tunivar _
- | Tvariant _, Tvariant _ -> true
-- | Tconstr (p, _, _), Tvar | Tvar, Tconstr (p, _, _) ->
-+ | Tconstr (p, _, _), Tvar _ | Tvar _, Tconstr (p, _, _) ->
- unif && min t3.level t4.level < Path.binding_time p
- | _ -> false
-
-@@ -931,21 +980,21 @@
-
- let explanation unif t3 t4 ppf =
- match t3.desc, t4.desc with
-- | Tfield _, Tvar | Tvar, Tfield _ ->
-+ | Tfield _, Tvar _ | Tvar _, Tfield _ ->
- fprintf ppf "@,Self type cannot escape its class"
-- | Tconstr (p, tl, _), Tvar
-+ | Tconstr (p, tl, _), Tvar _
- when unif && (tl = [] || t4.level < Path.binding_time p) ->
- fprintf ppf
- "@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
- path p
-- | Tvar, Tconstr (p, tl, _)
-+ | Tvar _, Tconstr (p, tl, _)
- when unif && (tl = [] || t3.level < Path.binding_time p) ->
- fprintf ppf
- "@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
- path p
-- | Tvar, Tunivar | Tunivar, Tvar ->
-+ | Tvar _, Tunivar _ | Tunivar _, Tvar _ ->
- fprintf ppf "@,The universal variable %a would escape its scope"
-- type_expr (if t3.desc = Tunivar then t3 else t4)
-+ type_expr (if is_Tunivar t3 then t3 else t4)
- | Tfield (lab, _, _, _), _
- | _, Tfield (lab, _, _, _) when lab = dummy_method ->
- fprintf ppf
-Index: typing/includecore.ml
-===================================================================
---- typing/includecore.ml (リビジョン 11207)
-+++ typing/includecore.ml (作æ¥ã‚³ãƒ”ー)
-@@ -61,7 +61,7 @@
- Tvariant row1, Tvariant row2 when is_absrow env (Btype.row_more row2) ->
- let row1 = Btype.row_repr row1 and row2 = Btype.row_repr row2 in
- Ctype.equal env true (ty1::params1) (row2.row_more::params2) &&
-- (match row1.row_more with {desc=Tvar|Tconstr _} -> true | _ -> false) &&
-+ (match row1.row_more with {desc=Tvar _|Tconstr _} -> true | _ -> false) &&
- let r1, r2, pairs =
- Ctype.merge_row_fields row1.row_fields row2.row_fields in
- (not row2.row_closed ||
-@@ -91,7 +91,7 @@
- let (fields2,rest2) = Ctype.flatten_fields fi2 in
- Ctype.equal env true (ty1::params1) (rest2::params2) &&
- let (fields1,rest1) = Ctype.flatten_fields fi1 in
-- (match rest1 with {desc=Tnil|Tvar|Tconstr _} -> true | _ -> false) &&
-+ (match rest1 with {desc=Tnil|Tvar _|Tconstr _} -> true | _ -> false) &&
- let pairs, miss1, miss2 = Ctype.associate_fields fields1 fields2 in
- miss2 = [] &&
- let tl1, tl2 =
-@@ -251,7 +251,7 @@
- let encode_val (mut, ty) rem =
- begin match mut with
- Asttypes.Mutable -> Predef.type_unit
-- | Asttypes.Immutable -> Btype.newgenty Tvar
-+ | Asttypes.Immutable -> Btype.newgenvar ()
- end
- ::ty::rem
-
-Index: typing/subst.ml
-===================================================================
---- typing/subst.ml (リビジョン 11207)
-+++ typing/subst.ml (作æ¥ã‚³ãƒ”ー)
-@@ -71,16 +71,19 @@
- let reset_for_saving () = new_id := -1
-
- let newpersty desc =
-- decr new_id; { desc = desc; level = generic_level; id = !new_id }
-+ decr new_id;
-+ { desc = desc; level = generic_level; id = !new_id }
-
- (* Similar to [Ctype.nondep_type_rec]. *)
- let rec typexp s ty =
- let ty = repr ty in
- match ty.desc with
-- Tvar | Tunivar ->
-+ Tvar _ | Tunivar _ ->
- if s.for_saving || ty.id < 0 then
-+ let desc = match ty.desc with (* Tvar _ -> Tvar None *) | d -> d in
- let ty' =
-- if s.for_saving then newpersty ty.desc else newty2 ty.level ty.desc
-+ if s.for_saving then newpersty desc
-+ else newty2 ty.level desc
- in
- save_desc ty ty.desc; ty.desc <- Tsubst ty'; ty'
- else ty
-@@ -94,7 +97,7 @@
- let desc = ty.desc in
- save_desc ty desc;
- (* Make a stub *)
-- let ty' = if s.for_saving then newpersty Tvar else newgenvar () in
-+ let ty' = if s.for_saving then newpersty (Tvar None) else newgenvar () in
- ty.desc <- Tsubst ty';
- ty'.desc <-
- begin match desc with
-@@ -127,10 +130,10 @@
- match more.desc with
- Tsubst ty -> ty
- | Tconstr _ -> typexp s more
-- | Tunivar | Tvar ->
-+ | Tunivar _ | Tvar _ ->
- save_desc more more.desc;
- if s.for_saving then newpersty more.desc else
-- if dup && more.desc <> Tunivar then newgenvar () else more
-+ if dup && is_Tvar more then newgenty more.desc else more
- | _ -> assert false
- in
- (* Register new type first for recursion *)
-Index: typing/types.ml
-===================================================================
---- typing/types.ml (リビジョン 11207)
-+++ typing/types.ml (作æ¥ã‚³ãƒ”ー)
-@@ -25,7 +25,7 @@
- mutable id: int }
-
- and type_desc =
-- Tvar
-+ Tvar of string option
- | Tarrow of label * type_expr * type_expr * commutable
- | Ttuple of type_expr list
- | Tconstr of Path.t * type_expr list * abbrev_memo ref
-@@ -35,7 +35,7 @@
- | Tlink of type_expr
- | Tsubst of type_expr (* for copying *)
- | Tvariant of row_desc
-- | Tunivar
-+ | Tunivar of string option
- | Tpoly of type_expr * type_expr list
- | Tpackage of Path.t * string list * type_expr list
-
-Index: ocamldoc/odoc_str.ml
-===================================================================
---- ocamldoc/odoc_str.ml (リビジョン 11207)
-+++ ocamldoc/odoc_str.ml (作æ¥ã‚³ãƒ”ー)
-@@ -31,7 +31,7 @@
- | Types.Tlink t2 | Types.Tsubst t2 -> is_arrow_type t2
- | Types.Ttuple _
- | Types.Tconstr _
-- | Types.Tvar | Types.Tunivar | Types.Tobject _ | Types.Tpoly _
-+ | Types.Tvar _ | Types.Tunivar _ | Types.Tobject _ | Types.Tpoly _
- | Types.Tfield _ | Types.Tnil | Types.Tvariant _ | Types.Tpackage _ -> false
-
- let raw_string_of_type_list sep type_list =
-@@ -43,7 +43,7 @@
- | Types.Tlink t2 | Types.Tsubst t2 -> need_parent t2
- | Types.Tconstr _ ->
- false
-- | Types.Tvar | Types.Tunivar | Types.Tobject _ | Types.Tpoly _
-+ | Types.Tvar _ | Types.Tunivar _ | Types.Tobject _ | Types.Tpoly _
- | Types.Tfield _ | Types.Tnil | Types.Tvariant _ | Types.Tpackage _ -> false
- in
- let print_one_type variance t =
-Index: ocamldoc/odoc_value.ml
-===================================================================
---- ocamldoc/odoc_value.ml (リビジョン 11207)
-+++ ocamldoc/odoc_value.ml (作æ¥ã‚³ãƒ”ー)
-@@ -77,13 +77,13 @@
- | Types.Tsubst texp ->
- iter texp
- | Types.Tpoly (texp, _) -> iter texp
-- | Types.Tvar
-+ | Types.Tvar _
- | Types.Ttuple _
- | Types.Tconstr _
- | Types.Tobject _
- | Types.Tfield _
- | Types.Tnil
-- | Types.Tunivar
-+ | Types.Tunivar _
- | Types.Tpackage _
- | Types.Tvariant _ ->
- []
-Index: ocamldoc/odoc_misc.ml
-===================================================================
---- ocamldoc/odoc_misc.ml (リビジョン 11207)
-+++ ocamldoc/odoc_misc.ml (作æ¥ã‚³ãƒ”ー)
-@@ -478,8 +478,8 @@
- match t with
- | Types.Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty.Types.desc
- | Types.Tconstr _
-- | Types.Tvar
-- | Types.Tunivar
-+ | Types.Tvar _
-+ | Types.Tunivar _
- | Types.Tpoly _
- | Types.Tarrow _
- | Types.Ttuple _
-Index: bytecomp/typeopt.ml
-===================================================================
---- bytecomp/typeopt.ml (リビジョン 11207)
-+++ bytecomp/typeopt.ml (作æ¥ã‚³ãƒ”ー)
-@@ -50,7 +50,7 @@
-
- let array_element_kind env ty =
- match scrape env ty with
-- | Tvar | Tunivar ->
-+ | Tvar _ | Tunivar _ ->
- Pgenarray
- | Tconstr(p, args, abbrev) ->
- if Path.same p Predef.path_int || Path.same p Predef.path_char then
-Index: bytecomp/translcore.ml
-===================================================================
---- bytecomp/translcore.ml (リビジョン 11207)
-+++ bytecomp/translcore.ml (作æ¥ã‚³ãƒ”ー)
-@@ -780,12 +780,13 @@
- begin match e.exp_type.desc with
- (* the following may represent a float/forward/lazy: need a
- forward_tag *)
-- | Tvar | Tlink _ | Tsubst _ | Tunivar
-+ | Tvar _ | Tlink _ | Tsubst _ | Tunivar _
- | Tpoly(_,_) | Tfield(_,_,_,_) ->
- Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e])
- (* the following cannot be represented as float/forward/lazy:
- optimize *)
-- | Tarrow(_,_,_,_) | Ttuple _ | Tpackage _ | Tobject(_,_) | Tnil | Tvariant _
-+ | Tarrow(_,_,_,_) | Ttuple _ | Tpackage _ | Tobject(_,_) | Tnil
-+ | Tvariant _
- -> transl_exp e
- (* optimize predefined types (excepted float) *)
- | Tconstr(_,_,_) ->
-Index: testsuite/tests/lib-hashtbl/htbl.ml
-===================================================================
---- testsuite/tests/lib-hashtbl/htbl.ml (リビジョン 11207)
-+++ testsuite/tests/lib-hashtbl/htbl.ml (作æ¥ã‚³ãƒ”ー)
-@@ -76,7 +76,7 @@
- struct
- type key = M.key
- type 'a t = (key, 'a) Hashtbl.t
-- let create = Hashtbl.create
-+ let create s = Hashtbl.create s
- let clear = Hashtbl.clear
- let copy = Hashtbl.copy
- let add = Hashtbl.add
-Index: toplevel/genprintval.ml
-===================================================================
---- toplevel/genprintval.ml (リビジョン 11207)
-+++ toplevel/genprintval.ml (作æ¥ã‚³ãƒ”ー)
-@@ -180,7 +180,7 @@
- find_printer env ty obj
- with Not_found ->
- match (Ctype.repr ty).desc with
-- | Tvar ->
-+ | Tvar _ | Tunivar _ ->
- Oval_stuff "<poly>"
- | Tarrow(_, ty1, ty2, _) ->
- Oval_stuff "<fun>"
-@@ -327,8 +327,6 @@
- fatal_error "Printval.outval_of_value"
- | Tpoly (ty, _) ->
- tree_of_val (depth - 1) obj ty
-- | Tunivar ->
-- Oval_stuff "<poly>"
- | Tpackage _ ->
- Oval_stuff "<module>"
- end
-Index: otherlibs/labltk/browser/searchid.ml
-===================================================================
---- otherlibs/labltk/browser/searchid.ml (リビジョン 11207)
-+++ otherlibs/labltk/browser/searchid.ml (作æ¥ã‚³ãƒ”ー)
-@@ -101,7 +101,7 @@
-
- let rec equal ~prefix t1 t2 =
- match (repr t1).desc, (repr t2).desc with
-- Tvar, Tvar -> true
-+ Tvar _, Tvar _ -> true
- | Tvariant row1, Tvariant row2 ->
- let row1 = row_repr row1 and row2 = row_repr row2 in
- let fields1 = filter_row_fields false row1.row_fields
-@@ -144,7 +144,7 @@
-
- let rec included ~prefix t1 t2 =
- match (repr t1).desc, (repr t2).desc with
-- Tvar, _ -> true
-+ Tvar _, _ -> true
- | Tvariant row1, Tvariant row2 ->
- let row1 = row_repr row1 and row2 = row_repr row2 in
- let fields1 = filter_row_fields false row1.row_fields
+++ /dev/null
-let f (x : < a:int; .. > as 'me1) = (x : < b:bool; .. > as 'me2);;
-let f (x : < a:int; .. > as 'me1) = (x : < a:int; b:bool; .. > as 'me2);;
-let f (x : [> `A of int] as 'me1) = (x : [> `B of bool] as 'me2);;
-let f (x : [> `A of int] as 'me1) = (x : [`A of int | `B of 'me2] as 'me2);;
+++ /dev/null
-(* cvs update -r varunion parsing typing bytecomp toplevel *)
-
-type t = private [> ];;
-type u = private [> ] ~ [t];;
-type v = [t | u];;
-let f x = (x : t :> v);;
-
-(* bad *)
-module Mix(X: sig type t = private [> ] end)
- (Y: sig type t = private [> ] end) =
- struct type t = [X.t | Y.t] end;;
-
-(* bad *)
-module Mix(X: sig type t = private [> `A of int ] end)
- (Y: sig type t = private [> `A of bool] ~ [X.t] end) =
- struct type t = [X.t | Y.t] end;;
-
-(* ok *)
-module Mix(X: sig type t = private [> `A of int ] end)
- (Y: sig type t = private [> `A of int] ~ [X.t] end) =
- struct type t = [X.t | Y.t] end;;
-
-(* bad *)
-module Mix(X: sig type t = private [> `A of int ] end)
- (Y: sig type t = private [> `B of bool] ~ [X.t] end) =
- struct type t = [X.t | Y.t] end;;
-
-type 'a t = private [> `L of 'a] ~ [`L];;
-
-(* ok *)
-module Mix(X: sig type t = private [> `A of int ] ~ [`B] end)
- (Y: sig type t = private [> `B of bool] ~ [X.t] end) =
- struct type t = [X.t | Y.t] let is_t = function #t -> true | _ -> false end;;
-
-module Mix(X: sig type t = private [> `A of int ] ~ [`B] end)
- (Y: sig type t = private [> `B of bool] ~ [X.t] end) =
- struct
- type t = [X.t | Y.t]
- let which = function #X.t -> `X | #Y.t -> `Y
- end;;
-
-module Mix(I: sig type t = private [> ] ~ [`A;`B] end)
- (X: sig type t = private [> I.t | `A of int ] ~ [`B] end)
- (Y: sig type t = private [> I.t | `B of bool] ~ [X.t] end) =
- struct
- type t = [X.t | Y.t]
- let which = function #X.t -> `X | #Y.t -> `Y
- end;;
-
-(* ok *)
-module M =
- Mix(struct type t = [`C of char] end)
- (struct type t = [`A of int | `C of char] end)
- (struct type t = [`B of bool | `C of char] end);;
-
-(* bad *)
-module M =
- Mix(struct type t = [`B of bool] end)
- (struct type t = [`A of int | `B of bool] end)
- (struct type t = [`B of bool | `C of char] end);;
-
-(* ok *)
-module M1 = struct type t = [`A of int | `C of char] end
-module M2 = struct type t = [`B of bool | `C of char] end
-module I = struct type t = [`C of char] end
-module M = Mix(I)(M1)(M2) ;;
-
-let c = (`C 'c' : M.t) ;;
-
-module M(X : sig type t = private [> `A] end) =
- struct let f (#X.t as x) = x end;;
-
-(* code generation *)
-type t = private [> `A ] ~ [`B];;
-match `B with #t -> 1 | `B -> 2;;
-
-module M : sig type t = private [> `A of int | `B] ~ [`C] end =
- struct type t = [`A of int | `B | `D of bool] end;;
-let f = function (`C | #M.t) -> 1+1 ;;
-let f = function (`A _ | `B #M.t) -> 1+1 ;;
-
-(* expression *)
-module Mix(X:sig type t = private [> ] val show: t -> string end)
- (Y:sig type t = private [> ] ~ [X.t] val show: t -> string end) =
- struct
- type t = [X.t | Y.t]
- let show : t -> string = function
- #X.t as x -> X.show x
- | #Y.t as y -> Y.show y
- end;;
-
-module EStr = struct
- type t = [`Str of string]
- let show (`Str s) = s
-end
-module EInt = struct
- type t = [`Int of int]
- let show (`Int i) = string_of_int i
-end
-module M = Mix(EStr)(EInt);;
-
-module type T = sig type t = private [> ] val show: t -> string end
-module Mix(X:T)(Y:T with type t = private [> ] ~ [X.t]) :
- T with type t = [X.t | Y.t] =
- struct
- type t = [X.t | Y.t]
- let show = function
- #X.t as x -> X.show x
- | #Y.t as y -> Y.show y
- end;;
-module M = Mix(EStr)(EInt);;
-
-(* deep *)
-module M : sig type t = private [> `A] end = struct type t = [`A] end
-module M' : sig type t = private [> ] end = struct type t = [M.t | `A] end;;
-
-(* bad *)
-type t = private [> ]
-type u = private [> `A of int] ~ [t] ;;
-
-(* ok *)
-type t = private [> `A of int]
-type u = private [> `A of int] ~ [t] ;;
-
-module F(X: sig
- type t = private [> ] ~ [`A;`B;`C;`D]
- type u = private [> `A|`B|`C] ~ [t; `D]
-end) : sig type v = private [< X.t | X.u | `D] end = struct
- open X
- let f = function #u -> 1 | #t -> 2 | `D -> 3
- let g = function #u|#t|`D -> 2
- type v = [t|u|`D]
-end
-
-(* ok *)
-module M = struct type t = private [> `A] end;;
-module M' : sig type t = private [> ] ~ [`A] end = M;;
-
-(* ok *)
-module type T = sig type t = private [> ] ~ [`A] end;;
-module type T' = T with type t = private [> `A];;
-
-(* ok *)
-type t = private [> ] ~ [`A]
-let f = function `A x -> x | #t -> 0
-type t' = private [< `A of int | t];;
-
-(* should be ok *)
-module F(X:sig end) :
- sig type t = private [> ] type u = private [> ] ~ [t] end =
- struct type t = [ `A] type u = [`B] end
-module M = F(String)
-let f = function #M.t -> 1 | #M.u -> 2
-let f = function #M.t -> 1 | _ -> 2
-type t = [M.t | M.u]
-let f = function #t -> 1 | _ -> 2;;
-module G(X : sig type t = private [> ] type u = private [> ] ~ [t] end) =
- struct let f = function #X.t -> 1 | _ -> 2 end;;
-module M1 = G(struct module N = F(String) type t = N.t type u = N.u end) ;;
-module M1 = G(struct type t = M.t type u = M.u end) ;;
-(* bad *)
-let f = function #F(String).t -> 1 | _ -> 2;;
-type t = [F(String).t | M.u]
-let f = function #t -> 1 | _ -> 2;;
-module N : sig type t = private [> ] end =
- struct type t = [F(String).t | M.u] end;;
-
-(* compatibility improvement *)
-type a = [`A of int | `B]
-type b = [`A of bool | `B]
-type c = private [> ] ~ [a;b]
-let f = function #c -> 1 | `A x -> truncate x
-type d = private [> ] ~ [a]
-let g = function #d -> 1 | `A x -> truncate x;;
-
-
-(* Expression Problem: functorial form *)
-
-type num = [ `Num of int ]
-
-module type Exp = sig
- type t = private [> num]
- val eval : t -> t
- val show : t -> string
-end
-
-module Num(X : Exp) = struct
- type t = num
- let eval (`Num _ as x) : X.t = x
- let show (`Num n) = string_of_int n
-end
-
-type 'a add = [ `Add of 'a * 'a ]
-
-module Add(X : Exp with type t = private [> num | 'a add] as 'a) = struct
- type t = X.t add
- let show (`Add(e1, e2) : t) = "("^ X.show e1 ^"+"^ X.show e2 ^")"
- let eval (`Add(e1, e2) : t) =
- let e1 = X.eval e1 and e2 = X.eval e2 in
- match e1, e2 with
- `Num n1, `Num n2 -> `Num (n1+n2)
- | `Num 0, e | e, `Num 0 -> e
- | e12 -> `Add e12
-end
-
-type 'a mul = [`Mul of 'a * 'a]
-
-module Mul(X : Exp with type t = private [> num | 'a mul] as 'a) = struct
- type t = X.t mul
- let show (`Mul(e1, e2) : t) = "("^ X.show e1 ^"*"^ X.show e2 ^")"
- let eval (`Mul(e1, e2) : t) =
- let e1 = X.eval e1 and e2 = X.eval e2 in
- match e1, e2 with
- `Num n1, `Num n2 -> `Num (n1*n2)
- | `Num 0, e | e, `Num 0 -> `Num 0
- | `Num 1, e | e, `Num 1 -> e
- | e12 -> `Mul e12
-end
-
-module Ext(X : sig type t = private [> ] end)(Y : sig type t end) = struct
- module type S =
- sig
- type t = private [> ] ~ [ X.t ]
- val eval : t -> Y.t
- val show : t -> string
- end
-end
-
-module Dummy = struct type t = [`Dummy] end
-
-module Mix(E : Exp)(E1 : Ext(Dummy)(E).S)(E2 : Ext(E1)(E).S) =
- struct
- type t = [E1.t | E2.t]
- let eval = function
- #E1.t as x -> E1.eval x
- | #E2.t as x -> E2.eval x
- let show = function
- #E1.t as x -> E1.show x
- | #E2.t as x -> E2.show x
- end
-
-module rec EAdd : (Exp with type t = [num | EAdd.t add]) =
- Mix(EAdd)(Num(EAdd))(Add(EAdd))
-
-(* A bit heavy: one must pass E to everybody *)
-module rec E : Exp with type t = [num | E.t add | E.t mul] =
- Mix(E)(Mix(E)(Num(E))(Add(E)))(Mul(E))
-
-let e = E.eval (`Add(`Mul(`Num 2,`Num 3),`Num 1))
-
-(* Alternatives *)
-(* Direct approach, no need of Mix *)
-module rec E : (Exp with type t = [num | E.t add | E.t mul]) =
- struct
- module E1 = Num(E)
- module E2 = Add(E)
- module E3 = Mul(E)
- type t = E.t
- let show = function
- | #num as x -> E1.show x
- | #add as x -> E2.show x
- | #mul as x -> E3.show x
- let eval = function
- | #num as x -> E1.eval x
- | #add as x -> E2.eval x
- | #mul as x -> E3.eval x
- end
-
-(* Do functor applications in Mix *)
-module type T = sig type t = private [> ] end
-module type Tnum = sig type t = private [> num] end
-
-module Ext(E : Tnum) = struct
- module type S = functor (Y : Exp with type t = E.t) ->
- sig
- type t = private [> num]
- val eval : t -> Y.t
- val show : t -> string
- end
-end
-
-module Ext'(E : Tnum)(X : T) = struct
- module type S = functor (Y : Exp with type t = E.t) ->
- sig
- type t = private [> ] ~ [ X.t ]
- val eval : t -> Y.t
- val show : t -> string
- end
-end
-
-module Mix(E : Exp)(F1 : Ext(E).S)(F2 : Ext'(E)(F1(E)).S) =
- struct
- module E1 = F1(E)
- module E2 = F2(E)
- type t = [E1.t | E2.t]
- let eval = function
- #E1.t as x -> E1.eval x
- | #E2.t as x -> E2.eval x
- let show = function
- #E1.t as x -> E1.show x
- | #E2.t as x -> E2.show x
- end
-
-module Join(E : Exp)(F1 : Ext(E).S)(F2 : Ext'(E)(F1(E)).S)
- (E' : Exp with type t = E.t) =
- Mix(E)(F1)(F2)
-
-module rec EAdd : (Exp with type t = [num | EAdd.t add]) =
- Mix(EAdd)(Num)(Add)
-
-module rec EMul : (Exp with type t = [num | EMul.t mul]) =
- Mix(EMul)(Num)(Mul)
-
-module rec E : (Exp with type t = [num | E.t add | E.t mul]) =
- Mix(E)(Join(E)(Num)(Add))(Mul)
-
-(* Linear extension by the end: not so nice *)
-module LExt(X : T) = struct
- module type S =
- sig
- type t
- val eval : t -> X.t
- val show : t -> string
- end
-end
-module LNum(E: Exp)(X : LExt(E).S with type t = private [> ] ~ [num]) =
- struct
- type t = [num | X.t]
- let show = function
- `Num n -> string_of_int n
- | #X.t as x -> X.show x
- let eval = function
- #num as x -> x
- | #X.t as x -> X.eval x
- end
-module LAdd(E : Exp with type t = private [> num | 'a add] as 'a)
- (X : LExt(E).S with type t = private [> ] ~ [add]) =
- struct
- type t = [E.t add | X.t]
- let show = function
- `Add(e1,e2) -> "("^ E.show e1 ^"+"^ E.show e2 ^")"
- | #X.t as x -> X.show x
- let eval = function
- `Add(e1,e2) ->
- let e1 = E.eval e1 and e2 = E.eval e2 in
- begin match e1, e2 with
- `Num n1, `Num n2 -> `Num (n1+n2)
- | `Num 0, e | e, `Num 0 -> e
- | e12 -> `Add e12
- end
- | #X.t as x -> X.eval x
- end
-module LEnd = struct
- type t = [`Dummy]
- let show `Dummy = ""
- let eval `Dummy = `Dummy
-end
-module rec L : Exp with type t = [num | L.t add | `Dummy] =
- LAdd(L)(LNum(L)(LEnd))
-
-(* Back to first form, but add map *)
-
-module Num(X : Exp) = struct
- type t = num
- let map f x = x
- let eval1 (`Num _ as x) : X.t = x
- let show (`Num n) = string_of_int n
-end
-
-module Add(X : Exp with type t = private [> num | 'a add] as 'a) = struct
- type t = X.t add
- let show (`Add(e1, e2) : t) = "("^ X.show e1 ^"+"^ X.show e2 ^")"
- let map f (`Add(e1, e2) : t) = `Add(f e1, f e2)
- let eval1 (`Add(e1, e2) as e : t) =
- match e1, e2 with
- `Num n1, `Num n2 -> `Num (n1+n2)
- | `Num 0, e | e, `Num 0 -> e
- | _ -> e
-end
-
-module Mul(X : Exp with type t = private [> num | 'a mul] as 'a) = struct
- type t = X.t mul
- let show (`Mul(e1, e2) : t) = "("^ X.show e1 ^"*"^ X.show e2 ^")"
- let map f (`Mul(e1, e2) : t) = `Mul(f e1, f e2)
- let eval1 (`Mul(e1, e2) as e : t) =
- match e1, e2 with
- `Num n1, `Num n2 -> `Num (n1*n2)
- | `Num 0, e | e, `Num 0 -> `Num 0
- | `Num 1, e | e, `Num 1 -> e
- | _ -> e
-end
-
-module Ext(X : sig type t = private [> ] end)(Y : sig type t end) = struct
- module type S =
- sig
- type t = private [> ] ~ [ X.t ]
- val map : (Y.t -> Y.t) -> t -> t
- val eval1 : t -> Y.t
- val show : t -> string
- end
-end
-
-module Mix(E : Exp)(E1 : Ext(Dummy)(E).S)(E2 : Ext(E1)(E).S) =
- struct
- type t = [E1.t | E2.t]
- let map f = function
- #E1.t as x -> (E1.map f x : E1.t :> t)
- | #E2.t as x -> (E2.map f x : E2.t :> t)
- let eval1 = function
- #E1.t as x -> E1.eval1 x
- | #E2.t as x -> E2.eval1 x
- let show = function
- #E1.t as x -> E1.show x
- | #E2.t as x -> E2.show x
- end
-
-module type ET = sig
- type t
- val map : (t -> t) -> t -> t
- val eval1 : t -> t
- val show : t -> string
-end
-
-module Fin(E : ET) = struct
- include E
- let rec eval e = eval1 (map eval e)
-end
-
-module rec EAdd : (Exp with type t = [num | EAdd.t add]) =
- Fin(Mix(EAdd)(Num(EAdd))(Add(EAdd)))
-
-module rec E : Exp with type t = [num | E.t add | E.t mul] =
- Fin(Mix(E)(Mix(E)(Num(E))(Add(E)))(Mul(E)))
-
-let e = E.eval (`Add(`Mul(`Num 2,`Num 3),`Num 1))
+++ /dev/null
-Index: typing/typemod.ml
-===================================================================
---- typing/typemod.ml (revision 13947)
-+++ typing/typemod.ml (working copy)
-@@ -80,6 +80,9 @@
- Typedtree.module_expr * Types.module_type) ref
- = ref (fun env m -> assert false)
-
-+let transl_modtype_fwd =
-+ ref (fun env m -> (assert false : Typedtree.module_type))
-+
- (* Merge one "with" constraint in a signature *)
-
- let rec add_rec_types env = function
-@@ -191,6 +194,21 @@
- merge env (extract_sig env loc mty) namelist None in
- (path_concat id path, lid, tcstr),
- Sig_module(id, Mty_signature newsg, rs) :: rem
-+ | (Sig_modtype(id, mtd) :: rem, [s], Pwith_modtype pmty)
-+ when Ident.name id = s ->
-+ let mty = !transl_modtype_fwd initial_env pmty in
-+ let mtd' = Modtype_manifest mty.mty_type in
-+ Includemod.modtype_declarations env id mtd' mtd;
-+ (Pident id, lid, Twith_modtype (Tmodtype_manifest mty)),
-+ Sig_modtype(id, mtd') :: rem
-+ | (Sig_modtype(id, mtd) :: rem, [s], Pwith_modtypesubst pmty)
-+ when Ident.name id = s ->
-+ let mty = !transl_modtype_fwd initial_env pmty in
-+ let mtd' = Modtype_manifest mty.mty_type in
-+ Includemod.modtype_declarations env id mtd' mtd;
-+ real_id := Some id;
-+ (Pident id, lid, Twith_modtypesubst (Tmodtype_manifest mty)),
-+ rem
- | (item :: rem, _, _) ->
- let (cstr, items) = merge (Env.add_item item env) rem namelist row_id
- in
-@@ -233,6 +251,12 @@
- let (path, _) = Typetexp.find_module initial_env loc lid.txt in
- let sub = Subst.add_module id path Subst.identity in
- Subst.signature sub sg
-+ | [s], Pwith_modtypesubst pmty ->
-+ let id =
-+ match !real_id with None -> assert false | Some id -> id in
-+ let mty = !transl_modtype_fwd initial_env pmty in
-+ let sub = Subst.add_modtype id mty.mty_type Subst.identity in
-+ Subst.signature sub sg
- | _ ->
- sg
- in
-@@ -649,6 +673,8 @@
- check_recmod_typedecls env2 sdecls dcl2;
- (dcl2, env2)
-
-+let () = transl_modtype_fwd := transl_modtype
-+
- (* Try to convert a module expression to a module path. *)
-
- exception Not_a_path
-Index: typing/typedtreeMap.ml
-===================================================================
---- typing/typedtreeMap.ml (revision 13947)
-+++ typing/typedtreeMap.ml (working copy)
-@@ -457,6 +457,9 @@
- | Twith_typesubst decl -> Twith_typesubst (map_type_declaration decl)
- | Twith_module (path, lid) -> cstr
- | Twith_modsubst (path, lid) -> cstr
-+ | Twith_modtype decl -> Twith_modtype (map_modtype_declaration decl)
-+ | Twith_modtypesubst decl ->
-+ Twith_modtypesubst (map_modtype_declaration decl)
- in
- Map.leave_with_constraint cstr
-
-Index: typing/typedtree.ml
-===================================================================
---- typing/typedtree.ml (revision 13947)
-+++ typing/typedtree.ml (working copy)
-@@ -255,6 +255,8 @@
- | Twith_module of Path.t * Longident.t loc
- | Twith_typesubst of type_declaration
- | Twith_modsubst of Path.t * Longident.t loc
-+ | Twith_modtype of modtype_declaration
-+ | Twith_modtypesubst of modtype_declaration
-
- and core_type =
- (* mutable because of [Typeclass.declare_method] *)
-Index: typing/typedtree.mli
-===================================================================
---- typing/typedtree.mli (revision 13947)
-+++ typing/typedtree.mli (working copy)
-@@ -254,6 +254,8 @@
- | Twith_module of Path.t * Longident.t loc
- | Twith_typesubst of type_declaration
- | Twith_modsubst of Path.t * Longident.t loc
-+ | Twith_modtype of modtype_declaration
-+ | Twith_modtypesubst of modtype_declaration
-
- and core_type =
- (* mutable because of [Typeclass.declare_method] *)
-Index: typing/includemod.ml
-===================================================================
---- typing/includemod.ml (revision 13947)
-+++ typing/includemod.ml (working copy)
-@@ -346,10 +346,10 @@
-
- (* Hide the context and substitution parameters to the outside world *)
-
--let modtypes env mty1 mty2 = modtypes env [] Subst.identity mty1 mty2
--let signatures env sig1 sig2 = signatures env [] Subst.identity sig1 sig2
--let type_declarations env id decl1 decl2 =
-- type_declarations env [] Subst.identity id decl1 decl2
-+let modtypes env = modtypes env [] Subst.identity
-+let signatures env = signatures env [] Subst.identity
-+let type_declarations env = type_declarations env [] Subst.identity
-+let modtype_declarations env = modtype_infos env [] Subst.identity
-
- (* Error report *)
-
-Index: typing/typedtreeIter.ml
-===================================================================
---- typing/typedtreeIter.ml (revision 13947)
-+++ typing/typedtreeIter.ml (working copy)
-@@ -408,6 +408,8 @@
- | Twith_module _ -> ()
- | Twith_typesubst decl -> iter_type_declaration decl
- | Twith_modsubst _ -> ()
-+ | Twith_modtype decl -> iter_modtype_declaration decl
-+ | Twith_modtypesubst decl -> iter_modtype_declaration decl
- end;
- Iter.leave_with_constraint cstr;
-
-Index: typing/includemod.mli
-===================================================================
---- typing/includemod.mli (revision 13947)
-+++ typing/includemod.mli (working copy)
-@@ -21,6 +21,8 @@
- val compunit: string -> signature -> string -> signature -> module_coercion
- val type_declarations:
- Env.t -> Ident.t -> type_declaration -> type_declaration -> unit
-+val modtype_declarations:
-+ Env.t -> Ident.t -> modtype_declaration -> modtype_declaration -> unit
-
- type symptom =
- Missing_field of Ident.t
-Index: typing/printtyped.ml
-===================================================================
---- typing/printtyped.ml (revision 13947)
-+++ typing/printtyped.ml (working copy)
-@@ -608,6 +608,12 @@
- type_declaration (i+1) ppf td;
- | Twith_module (li,_) -> line i ppf "Pwith_module %a\n" fmt_path li;
- | Twith_modsubst (li,_) -> line i ppf "Pwith_modsubst %a\n" fmt_path li;
-+ | Twith_modtype (td) ->
-+ line i ppf "Pwith_modtype\n";
-+ modtype_declaration (i+1) ppf td;
-+ | Twith_modtypesubst (td) ->
-+ line i ppf "Pwith_modtypesubst\n";
-+ modtype_declaration (i+1) ppf td;
-
- and module_expr i ppf x =
- line i ppf "module_expr %a\n" fmt_location x.mod_loc;
-Index: experimental/garrigue/with-module-type.diffs
-===================================================================
---- experimental/garrigue/with-module-type.diffs (revision 13947)
-+++ experimental/garrigue/with-module-type.diffs (working copy)
-@@ -1,95 +1,53 @@
--Index: parsing/parser.mly
--===================================================================
----- parsing/parser.mly (revision 12005)
--+++ parsing/parser.mly (working copy)
--@@ -1504,6 +1504,10 @@
-- { ($2, Pwith_module $4) }
-- | MODULE mod_longident COLONEQUAL mod_ext_longident
-- { ($2, Pwith_modsubst $4) }
--+ | MODULE TYPE mod_longident EQUAL module_type
--+ { ($3, Pwith_modtype $5) }
--+ | MODULE TYPE mod_longident COLONEQUAL module_type
--+ { ($3, Pwith_modtypesubst $5) }
-- ;
-- with_type_binder:
-- EQUAL { Public }
--Index: parsing/parsetree.mli
--===================================================================
----- parsing/parsetree.mli (revision 12005)
--+++ parsing/parsetree.mli (working copy)
--@@ -239,6 +239,8 @@
-- | Pwith_module of Longident.t
-- | Pwith_typesubst of type_declaration
-- | Pwith_modsubst of Longident.t
--+ | Pwith_modtype of module_type
--+ | Pwith_modtypesubst of module_type
--
-- (* Value expressions for the module language *)
--
--Index: parsing/printast.ml
--===================================================================
----- parsing/printast.ml (revision 12005)
--+++ parsing/printast.ml (working copy)
--@@ -575,6 +575,12 @@
-- type_declaration (i+1) ppf td;
-- | Pwith_module (li) -> line i ppf "Pwith_module %a\n" fmt_longident li;
-- | Pwith_modsubst (li) -> line i ppf "Pwith_modsubst %a\n" fmt_longident li;
--+ | Pwith_modtype (mty) ->
--+ line i ppf "Pwith_modtype\n";
--+ module_type (i+1) ppf mty;
--+ | Pwith_modtypesubst (mty) ->
--+ line i ppf "Pwith_modtype\n";
--+ module_type (i+1) ppf mty;
--
-- and module_expr i ppf x =
-- line i ppf "module_expr %a\n" fmt_location x.pmod_loc;
- Index: typing/typemod.ml
- ===================================================================
----- typing/typemod.ml (revision 12005)
-+--- typing/typemod.ml (revision 13947)
- +++ typing/typemod.ml (working copy)
--@@ -74,6 +74,8 @@
-- : (Env.t -> Parsetree.module_expr -> module_type) ref
-+@@ -80,6 +80,9 @@
-+ Typedtree.module_expr * Types.module_type) ref
- = ref (fun env m -> assert false)
-
--+let transl_modtype_fwd = ref (fun env m -> assert false)
-++let transl_modtype_fwd =
-++ ref (fun env m -> (assert false : Typedtree.module_type))
- +
- (* Merge one "with" constraint in a signature *)
-
- let rec add_rec_types env = function
--@@ -163,6 +165,19 @@
-- ignore(Includemod.modtypes env newmty mty);
-- real_id := Some id;
-- make_next_first rs rem
--+ | (Tsig_modtype(id, mtd) :: rem, [s], Pwith_modtype pmty)
-+@@ -191,6 +194,21 @@
-+ merge env (extract_sig env loc mty) namelist None in
-+ (path_concat id path, lid, tcstr),
-+ Sig_module(id, Mty_signature newsg, rs) :: rem
-++ | (Sig_modtype(id, mtd) :: rem, [s], Pwith_modtype pmty)
- + when Ident.name id = s ->
- + let mty = !transl_modtype_fwd initial_env pmty in
--+ let mtd' = Tmodtype_manifest mty in
-++ let mtd' = Modtype_manifest mty.mty_type in
- + Includemod.modtype_declarations env id mtd' mtd;
--+ Tsig_modtype(id, mtd') :: rem
--+ | (Tsig_modtype(id, mtd) :: rem, [s], Pwith_modtypesubst pmty)
-++ (Pident id, lid, Twith_modtype (Tmodtype_manifest mty)),
-++ Sig_modtype(id, mtd') :: rem
-++ | (Sig_modtype(id, mtd) :: rem, [s], Pwith_modtypesubst pmty)
- + when Ident.name id = s ->
- + let mty = !transl_modtype_fwd initial_env pmty in
--+ let mtd' = Tmodtype_manifest mty in
-++ let mtd' = Modtype_manifest mty.mty_type in
- + Includemod.modtype_declarations env id mtd' mtd;
- + real_id := Some id;
-++ (Pident id, lid, Twith_modtypesubst (Tmodtype_manifest mty)),
- + rem
-- | (Tsig_module(id, mty, rs) :: rem, s :: namelist, _)
-- when Ident.name id = s ->
-- let newsg = merge env (extract_sig env loc mty) namelist None in
--@@ -200,6 +215,12 @@
-- let (path, _) = Typetexp.find_module initial_env loc lid in
-+ | (item :: rem, _, _) ->
-+ let (cstr, items) = merge (Env.add_item item env) rem namelist row_id
-+ in
-+@@ -233,6 +251,12 @@
-+ let (path, _) = Typetexp.find_module initial_env loc lid.txt in
- let sub = Subst.add_module id path Subst.identity in
- Subst.signature sub sg
- + | [s], Pwith_modtypesubst pmty ->
- + let id =
- + match !real_id with None -> assert false | Some id -> id in
- + let mty = !transl_modtype_fwd initial_env pmty in
--+ let sub = Subst.add_modtype id mty Subst.identity in
-++ let sub = Subst.add_modtype id mty.mty_type Subst.identity in
- + Subst.signature sub sg
- | _ ->
-- sg
-- with Includemod.Error explanation ->
--@@ -499,6 +520,8 @@
-+ sg
-+ in
-+@@ -649,6 +673,8 @@
- check_recmod_typedecls env2 sdecls dcl2;
- (dcl2, env2)
-
-@@ -98,11 +56,51 @@
- (* Try to convert a module expression to a module path. *)
-
- exception Not_a_path
-+Index: typing/typedtreeMap.ml
-+===================================================================
-+--- typing/typedtreeMap.ml (revision 13947)
-++++ typing/typedtreeMap.ml (working copy)
-+@@ -457,6 +457,9 @@
-+ | Twith_typesubst decl -> Twith_typesubst (map_type_declaration decl)
-+ | Twith_module (path, lid) -> cstr
-+ | Twith_modsubst (path, lid) -> cstr
-++ | Twith_modtype decl -> Twith_modtype (map_modtype_declaration decl)
-++ | Twith_modtypesubst decl ->
-++ Twith_modtypesubst (map_modtype_declaration decl)
-+ in
-+ Map.leave_with_constraint cstr
-+
-+Index: typing/typedtree.ml
-+===================================================================
-+--- typing/typedtree.ml (revision 13947)
-++++ typing/typedtree.ml (working copy)
-+@@ -255,6 +255,8 @@
-+ | Twith_module of Path.t * Longident.t loc
-+ | Twith_typesubst of type_declaration
-+ | Twith_modsubst of Path.t * Longident.t loc
-++ | Twith_modtype of modtype_declaration
-++ | Twith_modtypesubst of modtype_declaration
-+
-+ and core_type =
-+ (* mutable because of [Typeclass.declare_method] *)
-+Index: typing/typedtree.mli
-+===================================================================
-+--- typing/typedtree.mli (revision 13947)
-++++ typing/typedtree.mli (working copy)
-+@@ -254,6 +254,8 @@
-+ | Twith_module of Path.t * Longident.t loc
-+ | Twith_typesubst of type_declaration
-+ | Twith_modsubst of Path.t * Longident.t loc
-++ | Twith_modtype of modtype_declaration
-++ | Twith_modtypesubst of modtype_declaration
-+
-+ and core_type =
-+ (* mutable because of [Typeclass.declare_method] *)
- Index: typing/includemod.ml
- ===================================================================
----- typing/includemod.ml (revision 12005)
-+--- typing/includemod.ml (revision 13947)
- +++ typing/includemod.ml (working copy)
--@@ -326,10 +326,10 @@
-+@@ -346,10 +346,10 @@
-
- (* Hide the context and substitution parameters to the outside world *)
-
-@@ -117,11 +115,24 @@
-
- (* Error report *)
-
-+Index: typing/typedtreeIter.ml
-+===================================================================
-+--- typing/typedtreeIter.ml (revision 13947)
-++++ typing/typedtreeIter.ml (working copy)
-+@@ -408,6 +408,8 @@
-+ | Twith_module _ -> ()
-+ | Twith_typesubst decl -> iter_type_declaration decl
-+ | Twith_modsubst _ -> ()
-++ | Twith_modtype decl -> iter_modtype_declaration decl
-++ | Twith_modtypesubst decl -> iter_modtype_declaration decl
-+ end;
-+ Iter.leave_with_constraint cstr;
-+
- Index: typing/includemod.mli
- ===================================================================
----- typing/includemod.mli (revision 12005)
-+--- typing/includemod.mli (revision 13947)
- +++ typing/includemod.mli (working copy)
--@@ -23,6 +23,8 @@
-+@@ -21,6 +21,8 @@
- val compunit: string -> signature -> string -> signature -> module_coercion
- val type_declarations:
- Env.t -> Ident.t -> type_declaration -> type_declaration -> unit
-@@ -130,53 +141,20 @@
-
- type symptom =
- Missing_field of Ident.t
--Index: testsuite/tests/typing-modules/Test.ml.reference
-+Index: typing/printtyped.ml
- ===================================================================
----- testsuite/tests/typing-modules/Test.ml.reference (revision 12005)
--+++ testsuite/tests/typing-modules/Test.ml.reference (working copy)
--@@ -6,4 +6,12 @@
-- # type -'a t
-- class type c = object method m : [ `A ] t end
-- # module M : sig val v : (#c as 'a) -> 'a end
--+# module type S = sig module type T module F : functor (X : T) -> T end
--+# module type T0 = sig type t end
--+# module type S1 = sig module type T = T0 module F : functor (X : T) -> T end
--+# module type S2 = sig module F : functor (X : T0) -> T0 end
--+# module type S3 =
--+ sig
--+ module F : functor (X : sig type t = int end) -> sig type t = int end
--+ end
-- #
--Index: testsuite/tests/typing-modules/Test.ml.principal.reference
--===================================================================
----- testsuite/tests/typing-modules/Test.ml.principal.reference (revision 12005)
--+++ testsuite/tests/typing-modules/Test.ml.principal.reference (working copy)
--@@ -6,4 +6,12 @@
-- # type -'a t
-- class type c = object method m : [ `A ] t end
-- # module M : sig val v : (#c as 'a) -> 'a end
--+# module type S = sig module type T module F : functor (X : T) -> T end
--+# module type T0 = sig type t end
--+# module type S1 = sig module type T = T0 module F : functor (X : T) -> T end
--+# module type S2 = sig module F : functor (X : T0) -> T0 end
--+# module type S3 =
--+ sig
--+ module F : functor (X : sig type t = int end) -> sig type t = int end
--+ end
-- #
--Index: testsuite/tests/typing-modules/Test.ml
--===================================================================
----- testsuite/tests/typing-modules/Test.ml (revision 12005)
--+++ testsuite/tests/typing-modules/Test.ml (working copy)
--@@ -9,3 +9,11 @@
-- class type c = object method m : [ `A ] t end;;
-- module M : sig val v : (#c as 'a) -> 'a end =
-- struct let v x = ignore (x :> c); x end;;
--+
--+(* with module type *)
--+
--+module type S = sig module type T module F(X:T) : T end;;
--+module type T0 = sig type t end;;
--+module type S1 = S with module type T = T0;;
--+module type S2 = S with module type T := T0;;
--+module type S3 = S with module type T := sig type t = int end;;
-+--- typing/printtyped.ml (revision 13947)
-++++ typing/printtyped.ml (working copy)
-+@@ -608,6 +608,12 @@
-+ type_declaration (i+1) ppf td;
-+ | Twith_module (li,_) -> line i ppf "Pwith_module %a\n" fmt_path li;
-+ | Twith_modsubst (li,_) -> line i ppf "Pwith_modsubst %a\n" fmt_path li;
-++ | Twith_modtype (td) ->
-++ line i ppf "Pwith_modtype\n";
-++ modtype_declaration (i+1) ppf td;
-++ | Twith_modtypesubst (td) ->
-++ line i ppf "Pwith_modtypesubst\n";
-++ modtype_declaration (i+1) ppf td;
-+
-+ and module_expr i ppf x =
-+ line i ppf "module_expr %a\n" fmt_location x.mod_loc;
-Index: parsing/pprintast.ml
-===================================================================
---- parsing/pprintast.ml (revision 13947)
-+++ parsing/pprintast.ml (working copy)
-@@ -847,18 +847,28 @@
- (self#list self#type_var_option ~sep:"," ~first:"(" ~last:")")
- ls self#longident_loc li self#type_declaration td
- | Pwith_module (li2) ->
-- pp f "module %a =@ %a" self#longident_loc li self#longident_loc li2;
-+ pp f "module %a =@ %a"
-+ self#longident_loc li self#longident_loc li2
- | Pwith_typesubst ({ptype_params=ls;_} as td) ->
- pp f "type@ %a %a :=@ %a"
- (self#list self#type_var_option ~sep:"," ~first:"(" ~last:")")
- ls self#longident_loc li
- self#type_declaration td
- | Pwith_modsubst (li2) ->
-- pp f "module %a :=@ %a" self#longident_loc li self#longident_loc li2 in
-+ pp f "module %a :=@ %a"
-+ self#longident_loc li self#longident_loc li2
-+ | Pwith_modtype mty ->
-+ pp f "module type %a =@ %a"
-+ self#longident_loc li self#module_type mty
-+ | Pwith_modtypesubst mty ->
-+ pp f "module type %a :=@ %a"
-+ self#longident_loc li self#module_type mty
-+ in
- (match l with
- | [] -> pp f "@[<hov2>%a@]" self#module_type mt
- | _ -> pp f "@[<hov2>(%a@ with@ %a)@]"
-- self#module_type mt (self#list longident_x_with_constraint ~sep:"@ and@ ") l )
-+ self#module_type mt
-+ (self#list longident_x_with_constraint ~sep:"@ and@ ") l )
- | Pmty_typeof me ->
- pp f "@[<hov2>module@ type@ of@ %a@]"
- self#module_expr me
-Index: parsing/parser.mly
-===================================================================
---- parsing/parser.mly (revision 13947)
-+++ parsing/parser.mly (working copy)
-@@ -1506,6 +1506,10 @@
- { (mkrhs $2 2, Pwith_module (mkrhs $4 4)) }
- | MODULE UIDENT COLONEQUAL mod_ext_longident
- { (mkrhs (Lident $2) 2, Pwith_modsubst (mkrhs $4 4)) }
-+ | MODULE TYPE mty_longident EQUAL module_type
-+ { (mkrhs $3 3, Pwith_modtype $5) }
-+ | MODULE TYPE ident COLONEQUAL module_type
-+ { (mkrhs (Lident $3) 3, Pwith_modtypesubst $5) }
- ;
- with_type_binder:
- EQUAL { Public }
-Index: parsing/ast_mapper.ml
-===================================================================
---- parsing/ast_mapper.ml (revision 13947)
-+++ parsing/ast_mapper.ml (working copy)
-@@ -164,6 +164,8 @@
- | Pwith_module s -> Pwith_module (map_loc sub s)
- | Pwith_typesubst d -> Pwith_typesubst (sub # type_declaration d)
- | Pwith_modsubst s -> Pwith_modsubst (map_loc sub s)
-+ | Pwith_modtype m -> Pwith_modtype (sub # module_type m)
-+ | Pwith_modtypesubst m -> Pwith_modtypesubst (sub # module_type m)
-
- let mk_item ?(loc = Location.none) x = {psig_desc = x; psig_loc = loc}
-
-Index: parsing/parsetree.mli
-===================================================================
---- parsing/parsetree.mli (revision 13947)
-+++ parsing/parsetree.mli (working copy)
-@@ -256,6 +256,8 @@
- | Pwith_module of Longident.t loc
- | Pwith_typesubst of type_declaration
- | Pwith_modsubst of Longident.t loc
-+ | Pwith_modtype of module_type
-+ | Pwith_modtypesubst of module_type
-
- (* Value expressions for the module language *)
-
-Index: parsing/printast.ml
-===================================================================
---- parsing/printast.ml (revision 13947)
-+++ parsing/printast.ml (working copy)
-@@ -590,6 +590,12 @@
- type_declaration (i+1) ppf td;
- | Pwith_module li -> line i ppf "Pwith_module %a\n" fmt_longident_loc li;
- | Pwith_modsubst li -> line i ppf "Pwith_modsubst %a\n" fmt_longident_loc li;
-+ | Pwith_modtype (mty) ->
-+ line i ppf "Pwith_modtype\n";
-+ module_type (i+1) ppf mty;
-+ | Pwith_modtypesubst (mty) ->
-+ line i ppf "Pwith_modtype\n";
-+ module_type (i+1) ppf mty;
-
- and module_expr i ppf x =
- line i ppf "module_expr %a\n" fmt_location x.pmod_loc;
+++ /dev/null
- _____ _ ____
-|_ _|__ ___| |_|___ \
- | |/ _ \/ __| __| __) |
- | | __/\__ \ |_ / __/
- |_|\___||___/\__|_____|
-
-ocamldep.opt -modules toto.ml > toto.ml.depends
-ocamldep.opt -modules tata.mli > tata.mli.depends
-ocamldep.opt -modules titi.ml > titi.ml.depends
-ocamldep.opt -modules tutu.mli > tutu.mli.depends
-ocamlc.opt -c -o tata.cmi tata.mli
-ocamlc.opt -c -o titi.cmo titi.ml
-ocamlc.opt -c -o tutu.cmi tutu.mli
-ocamlc.opt -c -o toto.cmo toto.ml
-ocamldep.opt -modules tata.ml > tata.ml.depends
-ocamldep.opt -modules tutu.ml > tutu.ml.depends
-ocamldep.opt -modules tyty.mli > tyty.mli.depends
-ocamldep.opt -pp camlp4o.opt -modules vivi.ml > vivi.ml.depends
-ocamlc.opt -c -o tyty.cmi tyty.mli
-ocamlc.opt -c -pp camlp4o.opt -o vivi.cmo vivi.ml
-ocamlc.opt -c -o tata.cmo tata.ml
-ocamlc.opt -c -o tutu.cmo tutu.ml
-ocamlc.opt tata.cmo titi.cmo vivi.cmo tutu.cmo toto.cmo -o toto.byte
-ocamlopt.opt -c -pp camlp4o.opt -o vivi.cmx vivi.ml
-ocamlopt.opt -c -o tata.cmx tata.ml
-ocamlopt.opt -c -o titi.cmx titi.ml
-ocamlopt.opt -c -o tutu.cmx tutu.ml
-ocamlopt.opt -c -o toto.cmx toto.ml
-ocamlopt.opt tata.cmx titi.cmx vivi.cmx tutu.cmx toto.cmx -o toto.native
-Warning: Using -- only run the last target
-toto.native: /home/danmey/src/ocaml-trunk/ocamlbuild/test/test2/_build/toto.native: Hello world!!!
-Tutu.tutu => 1
-Tata.tata => "TATA2"
-[cache hit] ocamldep.opt -modules toto.ml > toto.ml.depends
-[cache hit] ocamldep.opt -modules tata.mli > tata.mli.depends
-[cache hit] ocamlc.opt -c -o tata.cmi tata.mli
-[cache hit] ocamldep.opt -modules titi.ml > titi.ml.depends
-[cache hit] ocamlc.opt -c -o titi.cmo titi.ml
-[cache hit] ocamldep.opt -modules tutu.mli > tutu.mli.depends
-[cache hit] ocamlc.opt -c -o tutu.cmi tutu.mli
-[cache hit] ocamlc.opt -c -o toto.cmo toto.ml
-[cache hit] ocamldep.opt -modules tata.ml > tata.ml.depends
-[cache hit] ocamlc.opt -c -o tata.cmo tata.ml
-[cache hit] ocamldep.opt -modules tutu.ml > tutu.ml.depends
-[cache hit] ocamldep.opt -modules tyty.mli > tyty.mli.depends
-[cache hit] ocamlc.opt -c -o tyty.cmi tyty.mli
-[cache hit] ocamldep.opt -pp camlp4o.opt -modules vivi.ml > vivi.ml.depends
-[cache hit] ocamlc.opt -c -pp camlp4o.opt -o vivi.cmo vivi.ml
-[cache hit] ocamlc.opt -c -o tutu.cmo tutu.ml
-[cache hit] ocamlc.opt tata.cmo titi.cmo vivi.cmo tutu.cmo toto.cmo -o toto.byte
-[cache hit] ocamlopt.opt -c -o tata.cmx tata.ml
-[cache hit] ocamlopt.opt -c -o titi.cmx titi.ml
-[cache hit] ocamlopt.opt -c -pp camlp4o.opt -o vivi.cmx vivi.ml
-[cache hit] ocamlopt.opt -c -o tutu.cmx tutu.ml
-[cache hit] ocamlopt.opt -c -o toto.cmx toto.ml
-[cache hit] ocamlopt.opt tata.cmx titi.cmx vivi.cmx tutu.cmx toto.cmx -o toto.native
-Warning: Using -- only run the last target
-toto.native: /home/danmey/src/ocaml-trunk/ocamlbuild/test/test2/_build/toto.native: Hello world!!!
-Tutu.tutu => 1
-Tata.tata => "TATA2"
-ocamldep.opt -pp camlp4o.opt -modules vivi.ml > vivi.ml.depends
-ocamlc.opt -c -pp camlp4o.opt -o vivi.cmo vivi.ml
-ocamlc.opt tata.cmo titi.cmo vivi.cmo tutu.cmo toto.cmo -o toto.byte
-ocamlopt.opt -c -pp camlp4o.opt -o vivi.cmx vivi.ml
-ocamlopt.opt tata.cmx titi.cmx vivi.cmx tutu.cmx toto.cmx -o toto.native
-Warning: Using -- only run the last target
-toto.native: /home/danmey/src/ocaml-trunk/ocamlbuild/test/test2/_build/toto.native: Hello world!!!
-Tutu.tutu => 1
-Tata.tata => "TATA2"
-[cache hit] ocamldep.opt -modules toto.ml > toto.ml.depends
-[cache hit] ocamldep.opt -modules tata.mli > tata.mli.depends
-[cache hit] ocamlc.opt -c -o tata.cmi tata.mli
-[cache hit] ocamldep.opt -modules titi.ml > titi.ml.depends
-[cache hit] ocamlc.opt -c -o titi.cmo titi.ml
-[cache hit] ocamldep.opt -modules tutu.mli > tutu.mli.depends
-[cache hit] ocamlc.opt -c -o tutu.cmi tutu.mli
-[cache hit] ocamlc.opt -c -o toto.cmo toto.ml
-[cache hit] ocamldep.opt -modules tata.ml > tata.ml.depends
-[cache hit] ocamlc.opt -c -o tata.cmo tata.ml
-[cache hit] ocamldep.opt -modules tutu.ml > tutu.ml.depends
-[cache hit] ocamldep.opt -modules tyty.mli > tyty.mli.depends
-[cache hit] ocamlc.opt -c -o tyty.cmi tyty.mli
-[cache hit] ocamldep.opt -pp camlp4o.opt -modules vivi.ml > vivi.ml.depends
-[cache hit] ocamlc.opt -c -pp camlp4o.opt -o vivi.cmo vivi.ml
-[cache hit] ocamlc.opt -c -o tutu.cmo tutu.ml
-[cache hit] ocamlc.opt tata.cmo titi.cmo vivi.cmo tutu.cmo toto.cmo -o toto.byte
-[cache hit] ocamlopt.opt -c -o tata.cmx tata.ml
-[cache hit] ocamlopt.opt -c -o titi.cmx titi.ml
-[cache hit] ocamlopt.opt -c -pp camlp4o.opt -o vivi.cmx vivi.ml
-[cache hit] ocamlopt.opt -c -o tutu.cmx tutu.ml
-[cache hit] ocamlopt.opt -c -o toto.cmx toto.ml
-[cache hit] ocamlopt.opt tata.cmx titi.cmx vivi.cmx tutu.cmx toto.cmx -o toto.native
-Warning: Using -- only run the last target
-toto.native: /home/danmey/src/ocaml-trunk/ocamlbuild/test/test2/_build/toto.native: Hello world!!!
-Tutu.tutu => 1
-Tata.tata => "TATA2"
-ocamldep.opt -pp camlp4o.opt -modules vivi.ml > vivi.ml.depends
-ocamlc.opt -c -pp camlp4o.opt -o vivi.cmo vivi.ml
-ocamlc.opt -c -o tutu.cmo tutu.ml
-ocamlc.opt tata.cmo titi.cmo vivi.cmo tutu.cmo toto.cmo -o toto.byte
-ocamlopt.opt -c -pp camlp4o.opt -o vivi.cmx vivi.ml
-ocamlopt.opt -c -o tutu.cmx tutu.ml
-ocamlopt.opt -c -o toto.cmx toto.ml
-ocamlopt.opt tata.cmx titi.cmx vivi.cmx tutu.cmx toto.cmx -o toto.native
-Warning: Using -- only run the last target
-toto.native: /home/danmey/src/ocaml-trunk/ocamlbuild/test/test2/_build/toto.native: Hello world!!!
-Tutu.tutu => 2
-Tata.tata => "TATA2"
-[cache hit] ocamldep.opt -modules toto.ml > toto.ml.depends
-[cache hit] ocamldep.opt -modules tata.mli > tata.mli.depends
-[cache hit] ocamlc.opt -c -o tata.cmi tata.mli
-[cache hit] ocamldep.opt -modules titi.ml > titi.ml.depends
-[cache hit] ocamlc.opt -c -o titi.cmo titi.ml
-[cache hit] ocamldep.opt -modules tutu.mli > tutu.mli.depends
-[cache hit] ocamlc.opt -c -o tutu.cmi tutu.mli
-[cache hit] ocamlc.opt -c -o toto.cmo toto.ml
-[cache hit] ocamldep.opt -modules tata.ml > tata.ml.depends
-[cache hit] ocamlc.opt -c -o tata.cmo tata.ml
-[cache hit] ocamldep.opt -modules tutu.ml > tutu.ml.depends
-[cache hit] ocamldep.opt -modules tyty.mli > tyty.mli.depends
-[cache hit] ocamlc.opt -c -o tyty.cmi tyty.mli
-[cache hit] ocamldep.opt -pp camlp4o.opt -modules vivi.ml > vivi.ml.depends
-[cache hit] ocamlc.opt -c -pp camlp4o.opt -o vivi.cmo vivi.ml
-[cache hit] ocamlc.opt -c -o tutu.cmo tutu.ml
-[cache hit] ocamlc.opt tata.cmo titi.cmo vivi.cmo tutu.cmo toto.cmo -o toto.byte
-[cache hit] ocamlopt.opt -c -o tata.cmx tata.ml
-[cache hit] ocamlopt.opt -c -o titi.cmx titi.ml
-[cache hit] ocamlopt.opt -c -pp camlp4o.opt -o vivi.cmx vivi.ml
-[cache hit] ocamlopt.opt -c -o tutu.cmx tutu.ml
-[cache hit] ocamlopt.opt -c -o toto.cmx toto.ml
-[cache hit] ocamlopt.opt tata.cmx titi.cmx vivi.cmx tutu.cmx toto.cmx -o toto.native
-Warning: Using -- only run the last target
-toto.native: /home/danmey/src/ocaml-trunk/ocamlbuild/test/test2/_build/toto.native: Hello world!!!
-Tutu.tutu => 2
-Tata.tata => "TATA2"
- _____ _ _____
-|_ _|__ ___| |_|___ /
- | |/ _ \/ __| __| |_ \
- | | __/\__ \ |_ ___) |
- |_|\___||___/\__|____/
-
-ocamldep.opt -modules a.mli > a.mli.depends
-ocamlc.opt -c -o a.cmi a.mli
-ocamldep.opt -modules a.ml > a.ml.depends
-ocamldep.opt -modules b.mli > b.mli.depends
-ocamlc.opt -c -o b.cmi b.mli
-ocamlc.opt -c -o a.cmo a.ml
-ocamldep.opt -modules b.ml > b.ml.depends
-ocamldep.opt -modules c.mli > c.mli.depends
-ocamlc.opt -c -o c.cmi c.mli
-ocamlc.opt -c -o b.cmo b.ml
-ocamldep.opt -modules c.ml > c.ml.depends
-ocamldep.opt -modules d.mli > d.mli.depends
-ocamlc.opt -c -o d.cmi d.mli
-ocamlc.opt -c -o c.cmo c.ml
-ocamldep.opt -modules d.ml > d.ml.depends
-ocamldep.opt -modules e.mli > e.mli.depends
-ocamlc.opt -c -o e.cmi e.mli
-ocamlc.opt -c -o d.cmo d.ml
-ocamldep.opt -modules e.ml > e.ml.depends
-ocamldep.opt -modules f.mli > f.mli.depends
-ocamlc.opt -c -o f.cmi f.mli
-ocamlc.opt -c -o e.cmo e.ml
-ocamldep.opt -modules f.ml > f.ml.depends
-ocamlc.opt -c -o f.cmo f.ml
-ocamlc.opt unix.cma f.cmo e.cmo d.cmo c.cmo b.cmo a.cmo -o a.byte
-ocamlopt.opt -c -o f.cmx f.ml
-ocamlopt.opt -c -o e.cmx e.ml
-ocamlopt.opt -c -o d.cmx d.ml
-ocamlopt.opt -c -o c.cmx c.ml
-ocamlopt.opt -c -o b.cmx b.ml
-ocamlopt.opt -c -o a.cmx a.ml
-ocamlopt.opt unix.cmxa f.cmx e.cmx d.cmx c.cmx b.cmx a.cmx -o a.native
-ocamldoc.opt -dump a.odoc a.mli
-ocamldoc.opt -dump b.odoc b.mli
-ocamldoc.opt -dump c.odoc c.mli
-ocamldoc.opt -dump d.odoc d.mli
-ocamldoc.opt -dump e.odoc e.mli
-ocamldoc.opt -dump f.odoc f.mli
-rm -rf proj.docdir
-mkdir -p proj.docdir
-ocamldoc.opt -load a.odoc -load b.odoc -load c.odoc -load d.odoc -load e.odoc -load f.odoc -html -d proj.docdir
-[cache hit] ocamldep.opt -modules a.mli > a.mli.depends
-[cache hit] ocamlc.opt -c -o a.cmi a.mli
-[cache hit] ocamldep.opt -modules a.ml > a.ml.depends
-[cache hit] ocamldep.opt -modules b.mli > b.mli.depends
-[cache hit] ocamlc.opt -c -o b.cmi b.mli
-[cache hit] ocamlc.opt -c -o a.cmo a.ml
-[cache hit] ocamldep.opt -modules b.ml > b.ml.depends
-[cache hit] ocamldep.opt -modules c.mli > c.mli.depends
-[cache hit] ocamlc.opt -c -o c.cmi c.mli
-[cache hit] ocamlc.opt -c -o b.cmo b.ml
-[cache hit] ocamldep.opt -modules c.ml > c.ml.depends
-[cache hit] ocamldep.opt -modules d.mli > d.mli.depends
-[cache hit] ocamlc.opt -c -o d.cmi d.mli
-[cache hit] ocamlc.opt -c -o c.cmo c.ml
-[cache hit] ocamldep.opt -modules d.ml > d.ml.depends
-[cache hit] ocamldep.opt -modules e.mli > e.mli.depends
-[cache hit] ocamlc.opt -c -o e.cmi e.mli
-[cache hit] ocamlc.opt -c -o d.cmo d.ml
-[cache hit] ocamldep.opt -modules e.ml > e.ml.depends
-[cache hit] ocamldep.opt -modules f.mli > f.mli.depends
-[cache hit] ocamlc.opt -c -o f.cmi f.mli
-[cache hit] ocamlc.opt -c -o e.cmo e.ml
-[cache hit] ocamldep.opt -modules f.ml > f.ml.depends
-[cache hit] ocamlc.opt -c -o f.cmo f.ml
-[cache hit] ocamlc.opt unix.cma f.cmo e.cmo d.cmo c.cmo b.cmo a.cmo -o a.byte
-[cache hit] ocamlopt.opt -c -o f.cmx f.ml
-[cache hit] ocamlopt.opt -c -o e.cmx e.ml
-[cache hit] ocamlopt.opt -c -o d.cmx d.ml
-[cache hit] ocamlopt.opt -c -o c.cmx c.ml
-[cache hit] ocamlopt.opt -c -o b.cmx b.ml
-[cache hit] ocamlopt.opt -c -o a.cmx a.ml
-[cache hit] ocamlopt.opt unix.cmxa f.cmx e.cmx d.cmx c.cmx b.cmx a.cmx -o a.native
-[cache hit] ocamldoc.opt -dump a.odoc a.mli
-[cache hit] ocamldoc.opt -dump b.odoc b.mli
-[cache hit] ocamldoc.opt -dump c.odoc c.mli
-[cache hit] ocamldoc.opt -dump d.odoc d.mli
-[cache hit] ocamldoc.opt -dump e.odoc e.mli
-[cache hit] ocamldoc.opt -dump f.odoc f.mli
-[cache hit] rm -rf proj.docdir
-[cache hit] mkdir -p proj.docdir
-[cache hit] ocamldoc.opt -load a.odoc -load b.odoc -load c.odoc -load d.odoc -load e.odoc -load f.odoc -html -d proj.docdir
- _____ _ _ _
-|_ _|__ ___| |_| || |
- | |/ _ \/ __| __| || |_
- | | __/\__ \ |_|__ _|
- |_|\___||___/\__| |_|
-
-aa.mli.depends
-aa.mli
-aa.ml.depends
-bb.ml.depends
-bb.ml
-aa.ml
-aa.byte
-bb.ml
-aa.ml
-aa.native
-[cache hit] aa.mli.depends
-[cache hit] aa.mli
-[cache hit] aa.ml.depends
-[cache hit] bb.ml.depends
-[cache hit] bb.ml
-[cache hit] aa.ml
-[cache hit] aa.byte
-[cache hit] bb.ml
-[cache hit] aa.ml
-[cache hit] aa.native
- _____ _ ____
-|_ _|__ ___| |_| ___|
- | |/ _ \/ __| __|___ \
- | | __/\__ \ |_ ___) |
- |_|\___||___/\__|____/
-
-ocamldep.opt -modules d.ml > d.ml.depends
-ocamldep.opt -modules a.mli > a.mli.depends
-ocamlc.opt -c -o a.cmi a.mli
-ocamldep.opt -modules a.ml > a.ml.depends
-ocamldep.opt -modules stack.ml > stack.ml.depends
-ocamlc.opt -c -o stack.cmo stack.ml
-ocamldep.opt -modules b.ml > b.ml.depends
-ocamlc.opt -c -o a.cmo a.ml
-ocamlc.opt -c -o b.cmo b.ml
-ocamlc.opt -pack a.cmo b.cmo -o c.cmo
-ocamlc.opt -c -o d.cmo d.ml
-ocamlc.opt stack.cmo c.cmo d.cmo -o d.byte
-+ /home/danmey/src/ocaml-trunk/bin/ocamlc.opt stack.cmo c.cmo d.cmo -o d.byte
-File "stack.cmo", line 1:
-Warning 31: files stack.cmo and /home/danmey/src/ocaml-trunk/lib/ocaml/stdlib.cma(Stack) both define a module named Stack
-ocamlopt.opt -c -o stack.cmx stack.ml
-ocamlopt.opt -c -for-pack C -o a.cmx a.ml
-ocamlopt.opt -c -for-pack C -o b.cmx b.ml
-ocamlopt.opt -pack a.cmx b.cmx -o c.cmx ; then rm -f c.mli ; else rm -f c.mli ; exit 1; fi
-ocamlopt.opt -c -o d.cmx d.ml
-ocamlopt.opt stack.cmx c.cmx d.cmx -o d.native
-[cache hit] ocamldep.opt -modules d.ml > d.ml.depends
-[cache hit] ocamldep.opt -modules a.mli > a.mli.depends
-[cache hit] ocamlc.opt -c -o a.cmi a.mli
-[cache hit] ocamldep.opt -modules a.ml > a.ml.depends
-[cache hit] ocamldep.opt -modules stack.ml > stack.ml.depends
-[cache hit] ocamlc.opt -c -o stack.cmo stack.ml
-[cache hit] ocamlc.opt -c -o a.cmo a.ml
-[cache hit] ocamldep.opt -modules b.ml > b.ml.depends
-[cache hit] ocamlc.opt -c -o b.cmo b.ml
-[cache hit] ocamlc.opt -pack a.cmo b.cmo -o c.cmo
-[cache hit] ocamlc.opt -c -o d.cmo d.ml
-[cache hit] ocamlc.opt stack.cmo c.cmo d.cmo -o d.byte
-[cache hit] ocamlopt.opt -c -o stack.cmx stack.ml
-[cache hit] ocamlopt.opt -c -for-pack C -o a.cmx a.ml
-[cache hit] ocamlopt.opt -c -for-pack C -o b.cmx b.ml
-[cache hit] ocamlopt.opt -pack a.cmx b.cmx -o c.cmx ; then rm -f c.mli ; else rm -f c.mli ; exit 1; fi
-[cache hit] ocamlopt.opt -c -o d.cmx d.ml
-[cache hit] ocamlopt.opt stack.cmx c.cmx d.cmx -o d.native
- _____ _ __
-|_ _|__ ___| |_ / /_
- | |/ _ \/ __| __| '_ \
- | | __/\__ \ |_| (_) |
- |_|\___||___/\__|\___/
-
-ocamldep.opt -modules main.mli > main.mli.depends
-ocamlc.opt -c -o main.cmi main.mli
-ocamldep.opt -modules main.ml > main.ml.depends
-ocamldep.opt -modules a.mli > a.mli.depends
-ocamldep.opt -modules d.mli > d.mli.depends
-ocamlc.opt -c -o a.cmi a.mli
-ocamlc.opt -c -o d.cmi d.mli
-ocamlc.opt -c -o main.cmo main.ml
-ocamldep.opt -modules a.ml > a.ml.depends
-ocamldep.opt -modules b.mli > b.mli.depends
-ocamlc.opt -c -o b.cmi b.mli
-ocamldep.opt -modules d.ml > d.ml.depends
-ocamlc.opt -c -o a.cmo a.ml
-ocamlc.opt -c -o d.cmo d.ml
-ocamldep.opt -modules b.ml > b.ml.depends
-ocamlc.opt -c -o b.cmo b.ml
-ocamlc.opt d.cmo b.cmo a.cmo main.cmo -o main.byte
-[cache hit] ocamldep.opt -modules main.mli > main.mli.depends
-[cache hit] ocamlc.opt -c -o main.cmi main.mli
-[cache hit] ocamldep.opt -modules main.ml > main.ml.depends
-[cache hit] ocamldep.opt -modules a.mli > a.mli.depends
-[cache hit] ocamlc.opt -c -o a.cmi a.mli
-[cache hit] ocamldep.opt -modules d.mli > d.mli.depends
-[cache hit] ocamlc.opt -c -o d.cmi d.mli
-[cache hit] ocamlc.opt -c -o main.cmo main.ml
-[cache hit] ocamldep.opt -modules a.ml > a.ml.depends
-[cache hit] ocamldep.opt -modules b.mli > b.mli.depends
-[cache hit] ocamlc.opt -c -o b.cmi b.mli
-[cache hit] ocamlc.opt -c -o a.cmo a.ml
-[cache hit] ocamldep.opt -modules d.ml > d.ml.depends
-[cache hit] ocamlc.opt -c -o d.cmo d.ml
-[cache hit] ocamldep.opt -modules b.ml > b.ml.depends
-[cache hit] ocamlc.opt -c -o b.cmo b.ml
-[cache hit] ocamlc.opt d.cmo b.cmo a.cmo main.cmo -o main.byte
-ocamldep.opt -modules d.mli > d.mli.depends
-ocamlc.opt -c -o d.cmi d.mli
-ocamlc.opt -c -o main.cmo main.ml
-ocamldep.opt -modules b.mli > b.mli.depends
-+ /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules b.mli > b.mli.depends
-File "b.mli", line 13, characters 0-2:
-Error: Syntax error
-Command exited with code 2.
-ocamldep.opt -modules b.mli > b.mli.depends
-ocamlc.opt -c -o b.cmi b.mli
-ocamlc.opt -c -o d.cmo d.ml
-ocamlc.opt -c -o b.cmo b.ml
-ocamlc.opt d.cmo b.cmo a.cmo main.cmo -o main.byte
-[cache hit] ocamldep.opt -modules main.mli > main.mli.depends
-[cache hit] ocamlc.opt -c -o main.cmi main.mli
-[cache hit] ocamldep.opt -modules main.ml > main.ml.depends
-[cache hit] ocamldep.opt -modules a.mli > a.mli.depends
-[cache hit] ocamlc.opt -c -o a.cmi a.mli
-[cache hit] ocamldep.opt -modules d.mli > d.mli.depends
-[cache hit] ocamlc.opt -c -o d.cmi d.mli
-[cache hit] ocamlc.opt -c -o main.cmo main.ml
-[cache hit] ocamldep.opt -modules a.ml > a.ml.depends
-[cache hit] ocamldep.opt -modules b.mli > b.mli.depends
-[cache hit] ocamlc.opt -c -o b.cmi b.mli
-[cache hit] ocamlc.opt -c -o a.cmo a.ml
-[cache hit] ocamldep.opt -modules d.ml > d.ml.depends
-[cache hit] ocamlc.opt -c -o d.cmo d.ml
-[cache hit] ocamldep.opt -modules b.ml > b.ml.depends
-[cache hit] ocamlc.opt -c -o b.cmo b.ml
-[cache hit] ocamlc.opt d.cmo b.cmo a.cmo main.cmo -o main.byte
-PASS
- _____ _ _____
-|_ _|__ ___| ||___ |
- | |/ _ \/ __| __| / /
- | | __/\__ \ |_ / /
- |_|\___||___/\__/_/
-
-ocamlbuild.cmx -o myocamlbuild
-/home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules bb.mli > bb.mli.depends
-/home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o bb.cmi bb.mli
-/home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules bb.ml > bb.ml.depends
-/home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules cc.ml > cc.ml.depends
-/home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules aa.ml > aa.ml.depends
-/home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules c2.mli > c2.mli.depends
-/home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o aa.cmo aa.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o c2.cmi c2.mli
-/home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o bb.cmo bb.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o cc.cmo cc.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlc.opt -a bb.cmo cc.cmo -o bbcc.cma
-/home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules main.ml > main.ml.depends
-/home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules c3.ml > c3.ml.depends
-/home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o c3.cmo c3.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o main.cmo main.ml
-/home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules cool_plugin.ml > cool_plugin.ml.depends
-/home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o cool_plugin.cmo cool_plugin.ml
-/home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules c2.ml > c2.ml.depends
-/home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o c2.cmo c2.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlc.opt aa.cmo c2.cmo bbcc.cma c3.cmo main.cmo cool_plugin.cmo -o main.byte
-/home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o bb.cmx bb.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o aa.cmx aa.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o c2.cmx c2.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o cc.cmx cc.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -a bb.cmx cc.cmx -o bbcc.cmxa
-/home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o c3.cmx c3.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o main.cmx main.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlopt.opt aa.cmx c2.cmx bbcc.cmxa c3.cmx main.cmx -o main.native
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules bb.mli > bb.mli.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o bb.cmi bb.mli
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules bb.ml > bb.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o bb.cmo bb.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules cc.ml > cc.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules aa.ml > aa.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o aa.cmo aa.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules c2.mli > c2.mli.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o c2.cmi c2.mli
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o cc.cmo cc.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -a bb.cmo cc.cmo -o bbcc.cma
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules main.ml > main.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules c3.ml > c3.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o c3.cmo c3.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o main.cmo main.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules cool_plugin.ml > cool_plugin.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o cool_plugin.cmo cool_plugin.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules c2.ml > c2.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o c2.cmo c2.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt aa.cmo c2.cmo bbcc.cma c3.cmo main.cmo cool_plugin.cmo -o main.byte
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o bb.cmx bb.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o aa.cmx aa.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o c2.cmx c2.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o cc.cmx cc.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -a bb.cmx cc.cmx -o bbcc.cmxa
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o c3.cmx c3.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o main.cmx main.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt aa.cmx c2.cmx bbcc.cmxa c3.cmx main.cmx -o main.native
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules bb.mli > bb.mli.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o bb.cmi bb.mli
-/home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules bb.ml > bb.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules cc.ml > cc.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules aa.ml > aa.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o aa.cmo aa.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules c2.mli > c2.mli.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o c2.cmi c2.mli
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o cc.cmo cc.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o bb.cmo bb.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlc.opt -a bb.cmo cc.cmo -o bbcc.cma
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules main.ml > main.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules c3.ml > c3.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o c3.cmo c3.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o main.cmo main.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules cool_plugin.ml > cool_plugin.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o cool_plugin.cmo cool_plugin.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules c2.ml > c2.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o c2.cmo c2.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlc.opt aa.cmo c2.cmo bbcc.cma c3.cmo main.cmo cool_plugin.cmo -o main.byte
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o aa.cmx aa.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o bb.cmx bb.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o c2.cmx c2.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o cc.cmx cc.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -a bb.cmx cc.cmx -o bbcc.cmxa
-/home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o c3.cmx c3.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o main.cmx main.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlopt.opt aa.cmx c2.cmx bbcc.cmxa c3.cmx main.cmx -o main.native
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules bb.mli > bb.mli.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o bb.cmi bb.mli
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules bb.ml > bb.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o bb.cmo bb.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules cc.ml > cc.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules aa.ml > aa.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o aa.cmo aa.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules c2.mli > c2.mli.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o c2.cmi c2.mli
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o cc.cmo cc.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -a bb.cmo cc.cmo -o bbcc.cma
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules main.ml > main.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules c3.ml > c3.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o c3.cmo c3.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o main.cmo main.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules cool_plugin.ml > cool_plugin.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o cool_plugin.cmo cool_plugin.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules c2.ml > c2.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o c2.cmo c2.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt aa.cmo c2.cmo bbcc.cma c3.cmo main.cmo cool_plugin.cmo -o main.byte
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o bb.cmx bb.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o aa.cmx aa.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o c2.cmx c2.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o cc.cmx cc.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -a bb.cmx cc.cmx -o bbcc.cmxa
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o c3.cmx c3.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o main.cmx main.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt aa.cmx c2.cmx bbcc.cmxa c3.cmx main.cmx -o main.native
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules bb.mli > bb.mli.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o bb.cmi bb.mli
-/home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules bb.ml > bb.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules cc.ml > cc.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules aa.ml > aa.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o aa.cmo aa.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules c2.mli > c2.mli.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o c2.cmi c2.mli
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o cc.cmo cc.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o bb.cmo bb.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlc.opt -a bb.cmo cc.cmo -o bbcc.cma
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules main.ml > main.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules c3.ml > c3.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o c3.cmo c3.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o main.cmo main.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules cool_plugin.ml > cool_plugin.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o cool_plugin.cmo cool_plugin.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules c2.ml > c2.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o c2.cmo c2.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlc.opt aa.cmo c2.cmo bbcc.cma c3.cmo main.cmo cool_plugin.cmo -o main.byte
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o aa.cmx aa.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o bb.cmx bb.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o c2.cmx c2.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o cc.cmx cc.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -a bb.cmx cc.cmx -o bbcc.cmxa
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o c3.cmx c3.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o main.cmx main.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlopt.opt aa.cmx c2.cmx bbcc.cmxa c3.cmx main.cmx -o main.native
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules bb.mli > bb.mli.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o bb.cmi bb.mli
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules bb.ml > bb.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o bb.cmo bb.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules cc.ml > cc.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules aa.ml > aa.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o aa.cmo aa.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules c2.mli > c2.mli.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o c2.cmi c2.mli
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o cc.cmo cc.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -a bb.cmo cc.cmo -o bbcc.cma
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules main.ml > main.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules c3.ml > c3.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o c3.cmo c3.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o main.cmo main.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules cool_plugin.ml > cool_plugin.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o cool_plugin.cmo cool_plugin.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules c2.ml > c2.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o c2.cmo c2.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt aa.cmo c2.cmo bbcc.cma c3.cmo main.cmo cool_plugin.cmo -o main.byte
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o bb.cmx bb.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o aa.cmx aa.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o c2.cmx c2.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o cc.cmx cc.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -a bb.cmx cc.cmx -o bbcc.cmxa
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o c3.cmx c3.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o main.cmx main.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt aa.cmx c2.cmx bbcc.cmxa c3.cmx main.cmx -o main.native
- _____ _ ___
-|_ _|__ ___| |_( _ )
- | |/ _ \/ __| __/ _ \
- | | __/\__ \ || (_) |
- |_|\___||___/\__\___/
-
-ocamlbuild.cmx -o myocamlbuild
-/home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules a.ml > a.ml.depends
-/home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules myconfig.ml > myconfig.ml.depends
-/home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o myconfig.cmo myconfig.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o a.cmo a.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlc.opt myconfig.cmo a.cmo -o a.byte
-/home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o myconfig.cmx myconfig.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o a.cmx a.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlopt.opt myconfig.cmx a.cmx -o a.native
-cp -p a.byte a
-cp -p a.native a.opt
-cp -p a.byte bin/a.byte
-cp -p bin/a.byte bin/a
-cp -p a.native bin/a.native
-cp -p bin/a.native bin/a.opt
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules a.ml > a.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules myconfig.ml > myconfig.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o myconfig.cmo myconfig.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -o a.cmo a.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt myconfig.cmo a.cmo -o a.byte
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o myconfig.cmx myconfig.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -o a.cmx a.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt myconfig.cmx a.cmx -o a.native
-[cache hit] cp -p a.byte a
-[cache hit] cp -p a.native a.opt
-[cache hit] cp -p a.byte bin/a.byte
-[cache hit] cp -p bin/a.byte bin/a
-[cache hit] cp -p a.native bin/a.native
-[cache hit] cp -p bin/a.native bin/a.opt
- _____ _ ___
-|_ _|__ ___| |_ / _ \
- | |/ _ \/ __| __| (_) |
- | | __/\__ \ |_ \__, |
- |_|\___||___/\__| /_/
-
-Globexp for "\"hello\"" OK
-Globexp for "<hello>" OK
-Globexp for "<hel*lo>" OK
-Globexp for "<a> and <b> or <c>" OK
-Globexp for "<a> titi" OK
-Glob.eval "<[a]>" "a" = true OK
-Glob.eval "<[a]>" "b" = false OK
-Glob.eval "<[a]>" "a" = true OK
-Glob.eval "<[a]>" "b" = false OK
-Glob.eval "<[a]>" "a" = true OK
-Glob.eval "<[a]>" "b" = false OK
-Glob.eval "<[a-z]>" "a" = true OK
-Glob.eval "<[a-z]>" "e" = true OK
-Glob.eval "<[a-z]>" "k" = true OK
-Glob.eval "<[a-z]>" "z" = true OK
-Glob.eval "<[a-z]>" "0" = false OK
-Glob.eval "<[a-z]>" "A" = false OK
-Glob.eval "<[a-z]>" "~" = false OK
-Glob.eval "<[a-z]>" "a" = true OK
-Glob.eval "<[a-z]>" "e" = true OK
-Glob.eval "<[a-z]>" "k" = true OK
-Glob.eval "<[a-z]>" "z" = true OK
-Glob.eval "<[a-z]>" "0" = false OK
-Glob.eval "<[a-z]>" "A" = false OK
-Glob.eval "<[a-z]>" "~" = false OK
-Glob.eval "<[a-z]>" "a" = true OK
-Glob.eval "<[a-z]>" "e" = true OK
-Glob.eval "<[a-z]>" "k" = true OK
-Glob.eval "<[a-z]>" "z" = true OK
-Glob.eval "<[a-z]>" "0" = false OK
-Glob.eval "<[a-z]>" "A" = false OK
-Glob.eval "<[a-z]>" "~" = false OK
-Glob.eval "<[a-z][0-9]>" "a0" = true OK
-Glob.eval "<[a-z][0-9]>" "b9" = true OK
-Glob.eval "<[a-z][0-9]>" "a00" = false OK
-Glob.eval "<[a-z][0-9]>" "a0a" = false OK
-Glob.eval "<[a-z][0-9]>" "b0a" = false OK
-Glob.eval "<[a-z][0-9]>" "isduis" = false OK
-Glob.eval "<[a-z][0-9]>" "" = false OK
-Glob.eval "<[a-z][0-9]>" "a0" = true OK
-Glob.eval "<[a-z][0-9]>" "b9" = true OK
-Glob.eval "<[a-z][0-9]>" "a00" = false OK
-Glob.eval "<[a-z][0-9]>" "a0a" = false OK
-Glob.eval "<[a-z][0-9]>" "b0a" = false OK
-Glob.eval "<[a-z][0-9]>" "isduis" = false OK
-Glob.eval "<[a-z][0-9]>" "" = false OK
-Glob.eval "<[a-z][0-9]>" "a0" = true OK
-Glob.eval "<[a-z][0-9]>" "b9" = true OK
-Glob.eval "<[a-z][0-9]>" "a00" = false OK
-Glob.eval "<[a-z][0-9]>" "a0a" = false OK
-Glob.eval "<[a-z][0-9]>" "b0a" = false OK
-Glob.eval "<[a-z][0-9]>" "isduis" = false OK
-Glob.eval "<[a-z][0-9]>" "" = false OK
-Glob.eval "<hello>" "hello" = true OK
-Glob.eval "<hello>" "helli" = false OK
-Glob.eval "<hello>" "hello" = true OK
-Glob.eval "<hello>" "helli" = false OK
-Glob.eval "<hello>" "hello" = true OK
-Glob.eval "<hello>" "helli" = false OK
-Glob.eval "\"hello\"" "hello" = true OK
-Glob.eval "\"hello\"" "heidi" = false OK
-Glob.eval "\"hello\"" "hello" = true OK
-Glob.eval "\"hello\"" "heidi" = false OK
-Glob.eval "\"hello\"" "hello" = true OK
-Glob.eval "\"hello\"" "heidi" = false OK
-Glob.eval "<*>" "" = true OK
-Glob.eval "<*>" "a" = true OK
-Glob.eval "<*>" "ax" = true OK
-Glob.eval "<*>" "" = true OK
-Glob.eval "<*>" "a" = true OK
-Glob.eval "<*>" "ax" = true OK
-Glob.eval "<*>" "" = true OK
-Glob.eval "<*>" "a" = true OK
-Glob.eval "<*>" "ax" = true OK
-Glob.eval "<a*b>" "ab" = true OK
-Glob.eval "<a*b>" "acb" = true OK
-Glob.eval "<a*b>" "axxxxxb" = true OK
-Glob.eval "<a*b>" "ababbababb" = true OK
-Glob.eval "<a*b>" "abx" = false OK
-Glob.eval "<a*b>" "xxxxxab" = false OK
-Glob.eval "<a*b>" "xab" = false OK
-Glob.eval "<a*b>" "ab" = true OK
-Glob.eval "<a*b>" "acb" = true OK
-Glob.eval "<a*b>" "axxxxxb" = true OK
-Glob.eval "<a*b>" "ababbababb" = true OK
-Glob.eval "<a*b>" "abx" = false OK
-Glob.eval "<a*b>" "xxxxxab" = false OK
-Glob.eval "<a*b>" "xab" = false OK
-Glob.eval "<a*b>" "ab" = true OK
-Glob.eval "<a*b>" "acb" = true OK
-Glob.eval "<a*b>" "axxxxxb" = true OK
-Glob.eval "<a*b>" "ababbababb" = true OK
-Glob.eval "<a*b>" "abx" = false OK
-Glob.eval "<a*b>" "xxxxxab" = false OK
-Glob.eval "<a*b>" "xab" = false OK
-Glob.eval "<*.ml>" "hello.ml" = true OK
-Glob.eval "<*.ml>" ".ml" = true OK
-Glob.eval "<*.ml>" "ml" = false OK
-Glob.eval "<*.ml>" "" = false OK
-Glob.eval "<*.ml>" "toto.mli" = false OK
-Glob.eval "<*.ml>" "hello.ml" = true OK
-Glob.eval "<*.ml>" ".ml" = true OK
-Glob.eval "<*.ml>" "ml" = false OK
-Glob.eval "<*.ml>" "" = false OK
-Glob.eval "<*.ml>" "toto.mli" = false OK
-Glob.eval "<*.ml>" "hello.ml" = true OK
-Glob.eval "<*.ml>" ".ml" = true OK
-Glob.eval "<*.ml>" "ml" = false OK
-Glob.eval "<*.ml>" "" = false OK
-Glob.eval "<*.ml>" "toto.mli" = false OK
-Glob.eval "<a>" "a" = true OK
-Glob.eval "<a>" "" = false OK
-Glob.eval "<a>" "aa" = false OK
-Glob.eval "<a>" "ba" = false OK
-Glob.eval "<a>" "ab" = false OK
-Glob.eval "<a>" "abaa" = false OK
-Glob.eval "<a>" "a" = true OK
-Glob.eval "<a>" "" = false OK
-Glob.eval "<a>" "aa" = false OK
-Glob.eval "<a>" "ba" = false OK
-Glob.eval "<a>" "ab" = false OK
-Glob.eval "<a>" "abaa" = false OK
-Glob.eval "<a>" "a" = true OK
-Glob.eval "<a>" "" = false OK
-Glob.eval "<a>" "aa" = false OK
-Glob.eval "<a>" "ba" = false OK
-Glob.eval "<a>" "ab" = false OK
-Glob.eval "<a>" "abaa" = false OK
-Glob.eval "<ab>" "ab" = true OK
-Glob.eval "<ab>" "" = false OK
-Glob.eval "<ab>" "abab" = false OK
-Glob.eval "<ab>" "aba" = false OK
-Glob.eval "<ab>" "abx" = false OK
-Glob.eval "<ab>" "ab" = true OK
-Glob.eval "<ab>" "" = false OK
-Glob.eval "<ab>" "abab" = false OK
-Glob.eval "<ab>" "aba" = false OK
-Glob.eval "<ab>" "abx" = false OK
-Glob.eval "<ab>" "ab" = true OK
-Glob.eval "<ab>" "" = false OK
-Glob.eval "<ab>" "abab" = false OK
-Glob.eval "<ab>" "aba" = false OK
-Glob.eval "<ab>" "abx" = false OK
-Glob.eval "<ab?c>" "abac" = true OK
-Glob.eval "<ab?c>" "abxc" = true OK
-Glob.eval "<ab?c>" "abab" = false OK
-Glob.eval "<ab?c>" "ababab" = false OK
-Glob.eval "<ab?c>" "ababa" = false OK
-Glob.eval "<ab?c>" "abac" = true OK
-Glob.eval "<ab?c>" "abxc" = true OK
-Glob.eval "<ab?c>" "abab" = false OK
-Glob.eval "<ab?c>" "ababab" = false OK
-Glob.eval "<ab?c>" "ababa" = false OK
-Glob.eval "<ab?c>" "abac" = true OK
-Glob.eval "<ab?c>" "abxc" = true OK
-Glob.eval "<ab?c>" "abab" = false OK
-Glob.eval "<ab?c>" "ababab" = false OK
-Glob.eval "<ab?c>" "ababa" = false OK
-Glob.eval "<*ab?cd*>" "123abecd345" = true OK
-Glob.eval "<*ab?cd*>" "abccd" = true OK
-Glob.eval "<*ab?cd*>" "abccd345" = true OK
-Glob.eval "<*ab?cd*>" "ababcababccdab" = true OK
-Glob.eval "<*ab?cd*>" "abcd" = false OK
-Glob.eval "<*ab?cd*>" "aaaaabcdababcd" = false OK
-Glob.eval "<*ab?cd*>" "123abecd345" = true OK
-Glob.eval "<*ab?cd*>" "abccd" = true OK
-Glob.eval "<*ab?cd*>" "abccd345" = true OK
-Glob.eval "<*ab?cd*>" "ababcababccdab" = true OK
-Glob.eval "<*ab?cd*>" "abcd" = false OK
-Glob.eval "<*ab?cd*>" "aaaaabcdababcd" = false OK
-Glob.eval "<*ab?cd*>" "123abecd345" = true OK
-Glob.eval "<*ab?cd*>" "abccd" = true OK
-Glob.eval "<*ab?cd*>" "abccd345" = true OK
-Glob.eval "<*ab?cd*>" "ababcababccdab" = true OK
-Glob.eval "<*ab?cd*>" "abcd" = false OK
-Glob.eval "<*ab?cd*>" "aaaaabcdababcd" = false OK
-Glob.eval "<*this*is*a*test*>" "this is a test" = true OK
-Glob.eval "<*this*is*a*test*>" "You know this is a test really" = true OK
-Glob.eval "<*this*is*a*test*>" "thisisatest" = true OK
-Glob.eval "<*this*is*a*test*>" "thisatest" = false OK
-Glob.eval "<*this*is*a*test*>" "this is a test" = true OK
-Glob.eval "<*this*is*a*test*>" "You know this is a test really" = true OK
-Glob.eval "<*this*is*a*test*>" "thisisatest" = true OK
-Glob.eval "<*this*is*a*test*>" "thisatest" = false OK
-Glob.eval "<*this*is*a*test*>" "this is a test" = true OK
-Glob.eval "<*this*is*a*test*>" "You know this is a test really" = true OK
-Glob.eval "<*this*is*a*test*>" "thisisatest" = true OK
-Glob.eval "<*this*is*a*test*>" "thisatest" = false OK
-Glob.eval "<b*>" "bxx" = true OK
-Glob.eval "<b*>" "bx" = true OK
-Glob.eval "<b*>" "aaab" = false OK
-Glob.eval "<b*>" "" = false OK
-Glob.eval "<b*>" "bxx" = true OK
-Glob.eval "<b*>" "bx" = true OK
-Glob.eval "<b*>" "aaab" = false OK
-Glob.eval "<b*>" "" = false OK
-Glob.eval "<b*>" "bxx" = true OK
-Glob.eval "<b*>" "bx" = true OK
-Glob.eval "<b*>" "aaab" = false OK
-Glob.eval "<b*>" "" = false OK
-Glob.eval "<*>" "" = true OK
-Glob.eval "<*>" "a" = true OK
-Glob.eval "<*>" "aaa" = true OK
-Glob.eval "<*>" "aaaaa" = true OK
-Glob.eval "<*>" "" = true OK
-Glob.eval "<*>" "a" = true OK
-Glob.eval "<*>" "aaa" = true OK
-Glob.eval "<*>" "aaaaa" = true OK
-Glob.eval "<*>" "" = true OK
-Glob.eval "<*>" "a" = true OK
-Glob.eval "<*>" "aaa" = true OK
-Glob.eval "<*>" "aaaaa" = true OK
-Glob.eval "<?>" "a" = true OK
-Glob.eval "<?>" "" = false OK
-Glob.eval "<?>" "aaa" = false OK
-Glob.eval "<?>" "aaaaa" = false OK
-Glob.eval "<?>" "a" = true OK
-Glob.eval "<?>" "" = false OK
-Glob.eval "<?>" "aaa" = false OK
-Glob.eval "<?>" "aaaaa" = false OK
-Glob.eval "<?>" "a" = true OK
-Glob.eval "<?>" "" = false OK
-Glob.eval "<?>" "aaa" = false OK
-Glob.eval "<?>" "aaaaa" = false OK
-Glob.eval "<{a,b}>" "a" = true OK
-Glob.eval "<{a,b}>" "b" = true OK
-Glob.eval "<{a,b}>" "" = false OK
-Glob.eval "<{a,b}>" "aa" = false OK
-Glob.eval "<{a,b}>" "ab" = false OK
-Glob.eval "<{a,b}>" "ba" = false OK
-Glob.eval "<{a,b}>" "bb" = false OK
-Glob.eval "<{a,b}>" "c" = false OK
-Glob.eval "<{a,b}>" "a" = true OK
-Glob.eval "<{a,b}>" "b" = true OK
-Glob.eval "<{a,b}>" "" = false OK
-Glob.eval "<{a,b}>" "aa" = false OK
-Glob.eval "<{a,b}>" "ab" = false OK
-Glob.eval "<{a,b}>" "ba" = false OK
-Glob.eval "<{a,b}>" "bb" = false OK
-Glob.eval "<{a,b}>" "c" = false OK
-Glob.eval "<{a,b}>" "a" = true OK
-Glob.eval "<{a,b}>" "b" = true OK
-Glob.eval "<{a,b}>" "" = false OK
-Glob.eval "<{a,b}>" "aa" = false OK
-Glob.eval "<{a,b}>" "ab" = false OK
-Glob.eval "<{a,b}>" "ba" = false OK
-Glob.eval "<{a,b}>" "bb" = false OK
-Glob.eval "<{a,b}>" "c" = false OK
-Glob.eval "<toto.{ml,mli}>" "toto.ml" = true OK
-Glob.eval "<toto.{ml,mli}>" "toto.mli" = true OK
-Glob.eval "<toto.{ml,mli}>" "toto." = false OK
-Glob.eval "<toto.{ml,mli}>" "toto.mll" = false OK
-Glob.eval "<toto.{ml,mli}>" "toto.ml" = true OK
-Glob.eval "<toto.{ml,mli}>" "toto.mli" = true OK
-Glob.eval "<toto.{ml,mli}>" "toto." = false OK
-Glob.eval "<toto.{ml,mli}>" "toto.mll" = false OK
-Glob.eval "<toto.{ml,mli}>" "toto.ml" = true OK
-Glob.eval "<toto.{ml,mli}>" "toto.mli" = true OK
-Glob.eval "<toto.{ml,mli}>" "toto." = false OK
-Glob.eval "<toto.{ml,mli}>" "toto.mll" = false OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "acf" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "acg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "adf" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "adg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "aef" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "aeg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "bcf" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "bcg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "bdf" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "bdg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "bef" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "beg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "afg" = false OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "af" = false OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "aee" = false OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "acf" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "acg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "adf" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "adg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "aef" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "aeg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "bcf" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "bcg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "bdf" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "bdg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "bef" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "beg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "afg" = false OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "af" = false OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "aee" = false OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "acf" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "acg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "adf" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "adg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "aef" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "aeg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "bcf" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "bcg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "bdf" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "bdg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "bef" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "beg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "afg" = false OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "af" = false OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "aee" = false OK
-Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "a.ml" = true OK
-Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "b.ml" = true OK
-Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "a.mli" = true OK
-Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "hello.ml" = false OK
-Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "a.mli.x" = false OK
-Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "a.ml" = true OK
-Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "b.ml" = true OK
-Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "a.mli" = true OK
-Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "hello.ml" = false OK
-Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "a.mli.x" = false OK
-Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "a.ml" = true OK
-Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "b.ml" = true OK
-Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "a.mli" = true OK
-Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "hello.ml" = false OK
-Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "a.mli.x" = false OK
-Glob.eval "<*>" "alpha" = true OK
-Glob.eval "<*>" "beta" = true OK
-Glob.eval "<*>" "alpha/beta" = false OK
-Glob.eval "<*>" "gamma/delta" = false OK
-Glob.eval "<*>" "alpha" = true OK
-Glob.eval "<*>" "beta" = true OK
-Glob.eval "<*>" "alpha/beta" = false OK
-Glob.eval "<*>" "gamma/delta" = false OK
-Glob.eval "<*>" "alpha" = true OK
-Glob.eval "<*>" "beta" = true OK
-Glob.eval "<*>" "alpha/beta" = false OK
-Glob.eval "<*>" "gamma/delta" = false OK
-Glob.eval "<alpha/**/beta>" "alpha/beta" = true OK
-Glob.eval "<alpha/**/beta>" "alpha/gamma/beta" = true OK
-Glob.eval "<alpha/**/beta>" "alpha/gamma/delta/beta" = true OK
-Glob.eval "<alpha/**/beta>" "alpha" = false OK
-Glob.eval "<alpha/**/beta>" "beta" = false OK
-Glob.eval "<alpha/**/beta>" "gamma/delta" = false OK
-Glob.eval "<alpha/**/beta>" "alpha/beta" = true OK
-Glob.eval "<alpha/**/beta>" "alpha/gamma/beta" = true OK
-Glob.eval "<alpha/**/beta>" "alpha/gamma/delta/beta" = true OK
-Glob.eval "<alpha/**/beta>" "alpha" = false OK
-Glob.eval "<alpha/**/beta>" "beta" = false OK
-Glob.eval "<alpha/**/beta>" "gamma/delta" = false OK
-Glob.eval "<alpha/**/beta>" "alpha/beta" = true OK
-Glob.eval "<alpha/**/beta>" "alpha/gamma/beta" = true OK
-Glob.eval "<alpha/**/beta>" "alpha/gamma/delta/beta" = true OK
-Glob.eval "<alpha/**/beta>" "alpha" = false OK
-Glob.eval "<alpha/**/beta>" "beta" = false OK
-Glob.eval "<alpha/**/beta>" "gamma/delta" = false OK
-Glob.eval "<**/*.ml>" "toto.ml" = true OK
-Glob.eval "<**/*.ml>" "toto/tata.ml" = true OK
-Glob.eval "<**/*.ml>" "alpha/gamma/delta/beta.ml" = true OK
-Glob.eval "<**/*.ml>" "toto.mli" = false OK
-Glob.eval "<**/*.ml>" "toto.ml" = true OK
-Glob.eval "<**/*.ml>" "toto/tata.ml" = true OK
-Glob.eval "<**/*.ml>" "alpha/gamma/delta/beta.ml" = true OK
-Glob.eval "<**/*.ml>" "toto.mli" = false OK
-Glob.eval "<**/*.ml>" "toto.ml" = true OK
-Glob.eval "<**/*.ml>" "toto/tata.ml" = true OK
-Glob.eval "<**/*.ml>" "alpha/gamma/delta/beta.ml" = true OK
-Glob.eval "<**/*.ml>" "toto.mli" = false OK
-Glob.eval "<toto/**>" "toto/" = true OK
-Glob.eval "<toto/**>" "toto/tata" = true OK
-Glob.eval "<toto/**>" "toto/alpha/gamma/delta/beta.ml" = true OK
-Glob.eval "<toto/**>" "toto" = true OK
-Glob.eval "<toto/**>" "toto2/tata" = false OK
-Glob.eval "<toto/**>" "tata/titi" = false OK
-Glob.eval "<toto/**>" "toto/" = true OK
-Glob.eval "<toto/**>" "toto/tata" = true OK
-Glob.eval "<toto/**>" "toto/alpha/gamma/delta/beta.ml" = true OK
-Glob.eval "<toto/**>" "toto" = true OK
-Glob.eval "<toto/**>" "toto2/tata" = false OK
-Glob.eval "<toto/**>" "tata/titi" = false OK
-Glob.eval "<toto/**>" "toto/" = true OK
-Glob.eval "<toto/**>" "toto/tata" = true OK
-Glob.eval "<toto/**>" "toto/alpha/gamma/delta/beta.ml" = true OK
-Glob.eval "<toto/**>" "toto" = true OK
-Glob.eval "<toto/**>" "toto2/tata" = false OK
-Glob.eval "<toto/**>" "tata/titi" = false OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libfoo.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "src/bar/libfoo.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "otherlibs/unix/libunix.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "otherlibsliblib/unlibix/libunix.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libfoo/libbar.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "src/libfoo/boo/libbar.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "bar" = None OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libbar/foo.a" = None OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libfoo.b.a" = None OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libfoo.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "src/bar/libfoo.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "otherlibs/unix/libunix.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "otherlibsliblib/unlibix/libunix.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libfoo/libbar.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "src/libfoo/boo/libbar.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "bar" = None OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libbar/foo.a" = None OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libfoo.b.a" = None OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libfoo.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "src/bar/libfoo.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "otherlibs/unix/libunix.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "otherlibsliblib/unlibix/libunix.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libfoo/libbar.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "src/libfoo/boo/libbar.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "bar" = None OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libbar/foo.a" = None OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libfoo.b.a" = None OK
- _____ _ _ ___
-|_ _|__ ___| |_/ |/ _ \
- | |/ _ \/ __| __| | | | |
- | | __/\__ \ |_| | |_| |
- |_|\___||___/\__|_|\___/
-
-Globexp for "\"hello\"" OK
-Globexp for "<hello>" OK
-Globexp for "<hel*lo>" OK
-Globexp for "<a> and <b> or <c>" OK
-Globexp for "<a> titi" OK
-Glob.eval "<[a]>" "a" = true OK
-Glob.eval "<[a]>" "b" = false OK
-Glob.eval "<[a]>" "a" = true OK
-Glob.eval "<[a]>" "b" = false OK
-Glob.eval "<[a]>" "a" = true OK
-Glob.eval "<[a]>" "b" = false OK
-Glob.eval "<[a-z]>" "a" = true OK
-Glob.eval "<[a-z]>" "e" = true OK
-Glob.eval "<[a-z]>" "k" = true OK
-Glob.eval "<[a-z]>" "z" = true OK
-Glob.eval "<[a-z]>" "0" = false OK
-Glob.eval "<[a-z]>" "A" = false OK
-Glob.eval "<[a-z]>" "~" = false OK
-Glob.eval "<[a-z]>" "a" = true OK
-Glob.eval "<[a-z]>" "e" = true OK
-Glob.eval "<[a-z]>" "k" = true OK
-Glob.eval "<[a-z]>" "z" = true OK
-Glob.eval "<[a-z]>" "0" = false OK
-Glob.eval "<[a-z]>" "A" = false OK
-Glob.eval "<[a-z]>" "~" = false OK
-Glob.eval "<[a-z]>" "a" = true OK
-Glob.eval "<[a-z]>" "e" = true OK
-Glob.eval "<[a-z]>" "k" = true OK
-Glob.eval "<[a-z]>" "z" = true OK
-Glob.eval "<[a-z]>" "0" = false OK
-Glob.eval "<[a-z]>" "A" = false OK
-Glob.eval "<[a-z]>" "~" = false OK
-Glob.eval "<[a-z][0-9]>" "a0" = true OK
-Glob.eval "<[a-z][0-9]>" "b9" = true OK
-Glob.eval "<[a-z][0-9]>" "a00" = false OK
-Glob.eval "<[a-z][0-9]>" "a0a" = false OK
-Glob.eval "<[a-z][0-9]>" "b0a" = false OK
-Glob.eval "<[a-z][0-9]>" "isduis" = false OK
-Glob.eval "<[a-z][0-9]>" "" = false OK
-Glob.eval "<[a-z][0-9]>" "a0" = true OK
-Glob.eval "<[a-z][0-9]>" "b9" = true OK
-Glob.eval "<[a-z][0-9]>" "a00" = false OK
-Glob.eval "<[a-z][0-9]>" "a0a" = false OK
-Glob.eval "<[a-z][0-9]>" "b0a" = false OK
-Glob.eval "<[a-z][0-9]>" "isduis" = false OK
-Glob.eval "<[a-z][0-9]>" "" = false OK
-Glob.eval "<[a-z][0-9]>" "a0" = true OK
-Glob.eval "<[a-z][0-9]>" "b9" = true OK
-Glob.eval "<[a-z][0-9]>" "a00" = false OK
-Glob.eval "<[a-z][0-9]>" "a0a" = false OK
-Glob.eval "<[a-z][0-9]>" "b0a" = false OK
-Glob.eval "<[a-z][0-9]>" "isduis" = false OK
-Glob.eval "<[a-z][0-9]>" "" = false OK
-Glob.eval "<hello>" "hello" = true OK
-Glob.eval "<hello>" "helli" = false OK
-Glob.eval "<hello>" "hello" = true OK
-Glob.eval "<hello>" "helli" = false OK
-Glob.eval "<hello>" "hello" = true OK
-Glob.eval "<hello>" "helli" = false OK
-Glob.eval "\"hello\"" "hello" = true OK
-Glob.eval "\"hello\"" "heidi" = false OK
-Glob.eval "\"hello\"" "hello" = true OK
-Glob.eval "\"hello\"" "heidi" = false OK
-Glob.eval "\"hello\"" "hello" = true OK
-Glob.eval "\"hello\"" "heidi" = false OK
-Glob.eval "<*>" "" = true OK
-Glob.eval "<*>" "a" = true OK
-Glob.eval "<*>" "ax" = true OK
-Glob.eval "<*>" "" = true OK
-Glob.eval "<*>" "a" = true OK
-Glob.eval "<*>" "ax" = true OK
-Glob.eval "<*>" "" = true OK
-Glob.eval "<*>" "a" = true OK
-Glob.eval "<*>" "ax" = true OK
-Glob.eval "<a*b>" "ab" = true OK
-Glob.eval "<a*b>" "acb" = true OK
-Glob.eval "<a*b>" "axxxxxb" = true OK
-Glob.eval "<a*b>" "ababbababb" = true OK
-Glob.eval "<a*b>" "abx" = false OK
-Glob.eval "<a*b>" "xxxxxab" = false OK
-Glob.eval "<a*b>" "xab" = false OK
-Glob.eval "<a*b>" "ab" = true OK
-Glob.eval "<a*b>" "acb" = true OK
-Glob.eval "<a*b>" "axxxxxb" = true OK
-Glob.eval "<a*b>" "ababbababb" = true OK
-Glob.eval "<a*b>" "abx" = false OK
-Glob.eval "<a*b>" "xxxxxab" = false OK
-Glob.eval "<a*b>" "xab" = false OK
-Glob.eval "<a*b>" "ab" = true OK
-Glob.eval "<a*b>" "acb" = true OK
-Glob.eval "<a*b>" "axxxxxb" = true OK
-Glob.eval "<a*b>" "ababbababb" = true OK
-Glob.eval "<a*b>" "abx" = false OK
-Glob.eval "<a*b>" "xxxxxab" = false OK
-Glob.eval "<a*b>" "xab" = false OK
-Glob.eval "<*.ml>" "hello.ml" = true OK
-Glob.eval "<*.ml>" ".ml" = true OK
-Glob.eval "<*.ml>" "ml" = false OK
-Glob.eval "<*.ml>" "" = false OK
-Glob.eval "<*.ml>" "toto.mli" = false OK
-Glob.eval "<*.ml>" "hello.ml" = true OK
-Glob.eval "<*.ml>" ".ml" = true OK
-Glob.eval "<*.ml>" "ml" = false OK
-Glob.eval "<*.ml>" "" = false OK
-Glob.eval "<*.ml>" "toto.mli" = false OK
-Glob.eval "<*.ml>" "hello.ml" = true OK
-Glob.eval "<*.ml>" ".ml" = true OK
-Glob.eval "<*.ml>" "ml" = false OK
-Glob.eval "<*.ml>" "" = false OK
-Glob.eval "<*.ml>" "toto.mli" = false OK
-Glob.eval "<a>" "a" = true OK
-Glob.eval "<a>" "" = false OK
-Glob.eval "<a>" "aa" = false OK
-Glob.eval "<a>" "ba" = false OK
-Glob.eval "<a>" "ab" = false OK
-Glob.eval "<a>" "abaa" = false OK
-Glob.eval "<a>" "a" = true OK
-Glob.eval "<a>" "" = false OK
-Glob.eval "<a>" "aa" = false OK
-Glob.eval "<a>" "ba" = false OK
-Glob.eval "<a>" "ab" = false OK
-Glob.eval "<a>" "abaa" = false OK
-Glob.eval "<a>" "a" = true OK
-Glob.eval "<a>" "" = false OK
-Glob.eval "<a>" "aa" = false OK
-Glob.eval "<a>" "ba" = false OK
-Glob.eval "<a>" "ab" = false OK
-Glob.eval "<a>" "abaa" = false OK
-Glob.eval "<ab>" "ab" = true OK
-Glob.eval "<ab>" "" = false OK
-Glob.eval "<ab>" "abab" = false OK
-Glob.eval "<ab>" "aba" = false OK
-Glob.eval "<ab>" "abx" = false OK
-Glob.eval "<ab>" "ab" = true OK
-Glob.eval "<ab>" "" = false OK
-Glob.eval "<ab>" "abab" = false OK
-Glob.eval "<ab>" "aba" = false OK
-Glob.eval "<ab>" "abx" = false OK
-Glob.eval "<ab>" "ab" = true OK
-Glob.eval "<ab>" "" = false OK
-Glob.eval "<ab>" "abab" = false OK
-Glob.eval "<ab>" "aba" = false OK
-Glob.eval "<ab>" "abx" = false OK
-Glob.eval "<ab?c>" "abac" = true OK
-Glob.eval "<ab?c>" "abxc" = true OK
-Glob.eval "<ab?c>" "abab" = false OK
-Glob.eval "<ab?c>" "ababab" = false OK
-Glob.eval "<ab?c>" "ababa" = false OK
-Glob.eval "<ab?c>" "abac" = true OK
-Glob.eval "<ab?c>" "abxc" = true OK
-Glob.eval "<ab?c>" "abab" = false OK
-Glob.eval "<ab?c>" "ababab" = false OK
-Glob.eval "<ab?c>" "ababa" = false OK
-Glob.eval "<ab?c>" "abac" = true OK
-Glob.eval "<ab?c>" "abxc" = true OK
-Glob.eval "<ab?c>" "abab" = false OK
-Glob.eval "<ab?c>" "ababab" = false OK
-Glob.eval "<ab?c>" "ababa" = false OK
-Glob.eval "<*ab?cd*>" "123abecd345" = true OK
-Glob.eval "<*ab?cd*>" "abccd" = true OK
-Glob.eval "<*ab?cd*>" "abccd345" = true OK
-Glob.eval "<*ab?cd*>" "ababcababccdab" = true OK
-Glob.eval "<*ab?cd*>" "abcd" = false OK
-Glob.eval "<*ab?cd*>" "aaaaabcdababcd" = false OK
-Glob.eval "<*ab?cd*>" "123abecd345" = true OK
-Glob.eval "<*ab?cd*>" "abccd" = true OK
-Glob.eval "<*ab?cd*>" "abccd345" = true OK
-Glob.eval "<*ab?cd*>" "ababcababccdab" = true OK
-Glob.eval "<*ab?cd*>" "abcd" = false OK
-Glob.eval "<*ab?cd*>" "aaaaabcdababcd" = false OK
-Glob.eval "<*ab?cd*>" "123abecd345" = true OK
-Glob.eval "<*ab?cd*>" "abccd" = true OK
-Glob.eval "<*ab?cd*>" "abccd345" = true OK
-Glob.eval "<*ab?cd*>" "ababcababccdab" = true OK
-Glob.eval "<*ab?cd*>" "abcd" = false OK
-Glob.eval "<*ab?cd*>" "aaaaabcdababcd" = false OK
-Glob.eval "<*this*is*a*test*>" "this is a test" = true OK
-Glob.eval "<*this*is*a*test*>" "You know this is a test really" = true OK
-Glob.eval "<*this*is*a*test*>" "thisisatest" = true OK
-Glob.eval "<*this*is*a*test*>" "thisatest" = false OK
-Glob.eval "<*this*is*a*test*>" "this is a test" = true OK
-Glob.eval "<*this*is*a*test*>" "You know this is a test really" = true OK
-Glob.eval "<*this*is*a*test*>" "thisisatest" = true OK
-Glob.eval "<*this*is*a*test*>" "thisatest" = false OK
-Glob.eval "<*this*is*a*test*>" "this is a test" = true OK
-Glob.eval "<*this*is*a*test*>" "You know this is a test really" = true OK
-Glob.eval "<*this*is*a*test*>" "thisisatest" = true OK
-Glob.eval "<*this*is*a*test*>" "thisatest" = false OK
-Glob.eval "<b*>" "bxx" = true OK
-Glob.eval "<b*>" "bx" = true OK
-Glob.eval "<b*>" "aaab" = false OK
-Glob.eval "<b*>" "" = false OK
-Glob.eval "<b*>" "bxx" = true OK
-Glob.eval "<b*>" "bx" = true OK
-Glob.eval "<b*>" "aaab" = false OK
-Glob.eval "<b*>" "" = false OK
-Glob.eval "<b*>" "bxx" = true OK
-Glob.eval "<b*>" "bx" = true OK
-Glob.eval "<b*>" "aaab" = false OK
-Glob.eval "<b*>" "" = false OK
-Glob.eval "<*>" "" = true OK
-Glob.eval "<*>" "a" = true OK
-Glob.eval "<*>" "aaa" = true OK
-Glob.eval "<*>" "aaaaa" = true OK
-Glob.eval "<*>" "" = true OK
-Glob.eval "<*>" "a" = true OK
-Glob.eval "<*>" "aaa" = true OK
-Glob.eval "<*>" "aaaaa" = true OK
-Glob.eval "<*>" "" = true OK
-Glob.eval "<*>" "a" = true OK
-Glob.eval "<*>" "aaa" = true OK
-Glob.eval "<*>" "aaaaa" = true OK
-Glob.eval "<?>" "a" = true OK
-Glob.eval "<?>" "" = false OK
-Glob.eval "<?>" "aaa" = false OK
-Glob.eval "<?>" "aaaaa" = false OK
-Glob.eval "<?>" "a" = true OK
-Glob.eval "<?>" "" = false OK
-Glob.eval "<?>" "aaa" = false OK
-Glob.eval "<?>" "aaaaa" = false OK
-Glob.eval "<?>" "a" = true OK
-Glob.eval "<?>" "" = false OK
-Glob.eval "<?>" "aaa" = false OK
-Glob.eval "<?>" "aaaaa" = false OK
-Glob.eval "<{a,b}>" "a" = true OK
-Glob.eval "<{a,b}>" "b" = true OK
-Glob.eval "<{a,b}>" "" = false OK
-Glob.eval "<{a,b}>" "aa" = false OK
-Glob.eval "<{a,b}>" "ab" = false OK
-Glob.eval "<{a,b}>" "ba" = false OK
-Glob.eval "<{a,b}>" "bb" = false OK
-Glob.eval "<{a,b}>" "c" = false OK
-Glob.eval "<{a,b}>" "a" = true OK
-Glob.eval "<{a,b}>" "b" = true OK
-Glob.eval "<{a,b}>" "" = false OK
-Glob.eval "<{a,b}>" "aa" = false OK
-Glob.eval "<{a,b}>" "ab" = false OK
-Glob.eval "<{a,b}>" "ba" = false OK
-Glob.eval "<{a,b}>" "bb" = false OK
-Glob.eval "<{a,b}>" "c" = false OK
-Glob.eval "<{a,b}>" "a" = true OK
-Glob.eval "<{a,b}>" "b" = true OK
-Glob.eval "<{a,b}>" "" = false OK
-Glob.eval "<{a,b}>" "aa" = false OK
-Glob.eval "<{a,b}>" "ab" = false OK
-Glob.eval "<{a,b}>" "ba" = false OK
-Glob.eval "<{a,b}>" "bb" = false OK
-Glob.eval "<{a,b}>" "c" = false OK
-Glob.eval "<toto.{ml,mli}>" "toto.ml" = true OK
-Glob.eval "<toto.{ml,mli}>" "toto.mli" = true OK
-Glob.eval "<toto.{ml,mli}>" "toto." = false OK
-Glob.eval "<toto.{ml,mli}>" "toto.mll" = false OK
-Glob.eval "<toto.{ml,mli}>" "toto.ml" = true OK
-Glob.eval "<toto.{ml,mli}>" "toto.mli" = true OK
-Glob.eval "<toto.{ml,mli}>" "toto." = false OK
-Glob.eval "<toto.{ml,mli}>" "toto.mll" = false OK
-Glob.eval "<toto.{ml,mli}>" "toto.ml" = true OK
-Glob.eval "<toto.{ml,mli}>" "toto.mli" = true OK
-Glob.eval "<toto.{ml,mli}>" "toto." = false OK
-Glob.eval "<toto.{ml,mli}>" "toto.mll" = false OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "acf" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "acg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "adf" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "adg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "aef" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "aeg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "bcf" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "bcg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "bdf" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "bdg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "bef" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "beg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "afg" = false OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "af" = false OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "aee" = false OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "acf" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "acg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "adf" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "adg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "aef" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "aeg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "bcf" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "bcg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "bdf" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "bdg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "bef" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "beg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "afg" = false OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "af" = false OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "aee" = false OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "acf" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "acg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "adf" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "adg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "aef" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "aeg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "bcf" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "bcg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "bdf" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "bdg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "bef" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "beg" = true OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "afg" = false OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "af" = false OK
-Glob.eval "<{a,b}{c,[de]}{f,g}>" "aee" = false OK
-Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "a.ml" = true OK
-Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "b.ml" = true OK
-Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "a.mli" = true OK
-Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "hello.ml" = false OK
-Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "a.mli.x" = false OK
-Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "a.ml" = true OK
-Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "b.ml" = true OK
-Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "a.mli" = true OK
-Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "hello.ml" = false OK
-Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "a.mli.x" = false OK
-Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "a.ml" = true OK
-Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "b.ml" = true OK
-Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "a.mli" = true OK
-Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "hello.ml" = false OK
-Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "a.mli.x" = false OK
-Glob.eval "<*>" "alpha" = true OK
-Glob.eval "<*>" "beta" = true OK
-Glob.eval "<*>" "alpha/beta" = false OK
-Glob.eval "<*>" "gamma/delta" = false OK
-Glob.eval "<*>" "alpha" = true OK
-Glob.eval "<*>" "beta" = true OK
-Glob.eval "<*>" "alpha/beta" = false OK
-Glob.eval "<*>" "gamma/delta" = false OK
-Glob.eval "<*>" "alpha" = true OK
-Glob.eval "<*>" "beta" = true OK
-Glob.eval "<*>" "alpha/beta" = false OK
-Glob.eval "<*>" "gamma/delta" = false OK
-Glob.eval "<alpha/**/beta>" "alpha/beta" = true OK
-Glob.eval "<alpha/**/beta>" "alpha/gamma/beta" = true OK
-Glob.eval "<alpha/**/beta>" "alpha/gamma/delta/beta" = true OK
-Glob.eval "<alpha/**/beta>" "alpha" = false OK
-Glob.eval "<alpha/**/beta>" "beta" = false OK
-Glob.eval "<alpha/**/beta>" "gamma/delta" = false OK
-Glob.eval "<alpha/**/beta>" "alpha/beta" = true OK
-Glob.eval "<alpha/**/beta>" "alpha/gamma/beta" = true OK
-Glob.eval "<alpha/**/beta>" "alpha/gamma/delta/beta" = true OK
-Glob.eval "<alpha/**/beta>" "alpha" = false OK
-Glob.eval "<alpha/**/beta>" "beta" = false OK
-Glob.eval "<alpha/**/beta>" "gamma/delta" = false OK
-Glob.eval "<alpha/**/beta>" "alpha/beta" = true OK
-Glob.eval "<alpha/**/beta>" "alpha/gamma/beta" = true OK
-Glob.eval "<alpha/**/beta>" "alpha/gamma/delta/beta" = true OK
-Glob.eval "<alpha/**/beta>" "alpha" = false OK
-Glob.eval "<alpha/**/beta>" "beta" = false OK
-Glob.eval "<alpha/**/beta>" "gamma/delta" = false OK
-Glob.eval "<**/*.ml>" "toto.ml" = true OK
-Glob.eval "<**/*.ml>" "toto/tata.ml" = true OK
-Glob.eval "<**/*.ml>" "alpha/gamma/delta/beta.ml" = true OK
-Glob.eval "<**/*.ml>" "toto.mli" = false OK
-Glob.eval "<**/*.ml>" "toto.ml" = true OK
-Glob.eval "<**/*.ml>" "toto/tata.ml" = true OK
-Glob.eval "<**/*.ml>" "alpha/gamma/delta/beta.ml" = true OK
-Glob.eval "<**/*.ml>" "toto.mli" = false OK
-Glob.eval "<**/*.ml>" "toto.ml" = true OK
-Glob.eval "<**/*.ml>" "toto/tata.ml" = true OK
-Glob.eval "<**/*.ml>" "alpha/gamma/delta/beta.ml" = true OK
-Glob.eval "<**/*.ml>" "toto.mli" = false OK
-Glob.eval "<toto/**>" "toto/" = true OK
-Glob.eval "<toto/**>" "toto/tata" = true OK
-Glob.eval "<toto/**>" "toto/alpha/gamma/delta/beta.ml" = true OK
-Glob.eval "<toto/**>" "toto" = true OK
-Glob.eval "<toto/**>" "toto2/tata" = false OK
-Glob.eval "<toto/**>" "tata/titi" = false OK
-Glob.eval "<toto/**>" "toto/" = true OK
-Glob.eval "<toto/**>" "toto/tata" = true OK
-Glob.eval "<toto/**>" "toto/alpha/gamma/delta/beta.ml" = true OK
-Glob.eval "<toto/**>" "toto" = true OK
-Glob.eval "<toto/**>" "toto2/tata" = false OK
-Glob.eval "<toto/**>" "tata/titi" = false OK
-Glob.eval "<toto/**>" "toto/" = true OK
-Glob.eval "<toto/**>" "toto/tata" = true OK
-Glob.eval "<toto/**>" "toto/alpha/gamma/delta/beta.ml" = true OK
-Glob.eval "<toto/**>" "toto" = true OK
-Glob.eval "<toto/**>" "toto2/tata" = false OK
-Glob.eval "<toto/**>" "tata/titi" = false OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libfoo.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "src/bar/libfoo.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "otherlibs/unix/libunix.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "otherlibsliblib/unlibix/libunix.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libfoo/libbar.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "src/libfoo/boo/libbar.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "bar" = None OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libbar/foo.a" = None OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libfoo.b.a" = None OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libfoo.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "src/bar/libfoo.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "otherlibs/unix/libunix.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "otherlibsliblib/unlibix/libunix.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libfoo/libbar.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "src/libfoo/boo/libbar.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "bar" = None OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libbar/foo.a" = None OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libfoo.b.a" = None OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libfoo.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "src/bar/libfoo.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "otherlibs/unix/libunix.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "otherlibsliblib/unlibix/libunix.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libfoo/libbar.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "src/libfoo/boo/libbar.a" OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "bar" = None OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libbar/foo.a" = None OK
-Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libfoo.b.a" = None OK
- _____ _ _ _
-|_ _|__ ___| |_/ / |
- | |/ _ \/ __| __| | |
- | | __/\__ \ |_| | |
- |_|\___||___/\__|_|_|
-
-ocamlbuild.cmx -o myocamlbuild
-/home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules a/aa.mli > a/aa.mli.depends
-/home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -I a -I b -o a/aa.cmi a/aa.mli
-/home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules a/aa.ml > a/aa.ml.depends
-/home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules b/bb.ml > b/bb.ml.depends
-/home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -I b -I a -o b/bb.cmo b/bb.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -I a -I b -o a/aa.cmo a/aa.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlc.opt -a b/bb.cmo -o b/libb.cma
-/home/danmey/src/ocaml-trunk/bin/ocamlc.opt b/libb.cma a/aa.cmo -o a/aa.byte
-/home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -I b -I a -o b/bb.cmx b/bb.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -I a -I b -o a/aa.cmx a/aa.ml
-/home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -a b/bb.cmx -o b/libb.cmxa
-/home/danmey/src/ocaml-trunk/bin/ocamlopt.opt b/libb.cmxa a/aa.cmx -o a/aa.native
-looks if libs are there
-_build/b/libb.a
-_build/b/libb.cma
-_build/b/libb.cmxa
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules a/aa.mli > a/aa.mli.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -I a -I b -o a/aa.cmi a/aa.mli
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules a/aa.ml > a/aa.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamldep.opt -modules b/bb.ml > b/bb.ml.depends
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -I b -I a -o b/bb.cmo b/bb.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -c -I a -I b -o a/aa.cmo a/aa.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt -a b/bb.cmo -o b/libb.cma
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlc.opt b/libb.cma a/aa.cmo -o a/aa.byte
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -I b -I a -o b/bb.cmx b/bb.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -c -I a -I b -o a/aa.cmx a/aa.ml
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt -a b/bb.cmx -o b/libb.cmxa
-[cache hit] /home/danmey/src/ocaml-trunk/bin/ocamlopt.opt b/libb.cmxa a/aa.cmx -o a/aa.native
- _____ _ _ ____
-|_ _|__ ___| |_/ |___ \
- | |/ _ \/ __| __| | __) |
- | | __/\__ \ |_| |/ __/
- |_|\___||___/\__|_|_____|
-
-ocamldep.opt -modules Main.ml > Main.ml.depends
-Packed.ml.depends
-Lib.mli.depends
-Lib.mli
-Packed.ml
-Packed.cmo -o Pack.cmo
-ocamlc.opt -c -I lib -o Main.cmo Main.ml
-Lib.ml.depends
-Lib.ml
-Packed.ml
-Packed.cmx -o Pack.cmx ; then rm -f Pack.mli ; else rm -f Pack.mli ; exit 1; fi
-ocamlopt.opt -c -I lib -o Main.cmx Main.ml
-Lib.cmx Pack.cmx Main.cmx -o Main.native
-Lib.ml
-Lib.cmo Pack.cmo Main.cmo -o Main.byte
-looks if executable are there
-_build/Main.byte
-_build/Main.byte
-_build/Main.native
- _____ _ __ ___ _ _
-|_ _|__ ___| |_ \ \ / (_)_ __| |_ _ _ __ _| |
- | |/ _ \/ __| __| \ \ / /| | '__| __| | | |/ _` | |
- | | __/\__ \ |_ \ V / | | | | |_| |_| | (_| | |
- |_|\___||___/\__| \_/ |_|_| \__|\__,_|\__,_|_|
-
- _____ _
-|_ _|_ _ _ __ __ _ ___| |_ ___
- | |/ _` | '__/ _` |/ _ \ __/ __|
- | | (_| | | | (_| | __/ |_\__ \
- |_|\__,_|_| \__, |\___|\__|___/
- |___/
+++ /dev/null
-#########################################################################
-# #
-# OCaml #
-# #
-# Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt #
-# #
-# Copyright 2007 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-#!/bin/sh
-set -e
-cd `dirname $0`
-
-export OCB=$PWD/../../_build/ocamlbuild/ocamlbuild.native
-
-myfiglet() {
- figlet $@ | sed 's/ *$//'
-}
-
-if figlet ""; then
- BANNER=myfiglet
-else
- echo "Install figlet to have a better output, press enter to continue with echo"
- read
- BANNER=echo
-fi
-
-HERE=`pwd`
-
-$BANNER Test2
-./test2/test.sh $@
-$BANNER Test3
-./test3/test.sh $@
-$BANNER Test4
-./test4/test.sh $@
-$BANNER Test5
-./test5/test.sh $@
-$BANNER Test6
-./test6/test.sh $@
-$BANNER Test7
-./test7/test.sh $@
-$BANNER Test8
-./test8/test.sh $@
-$BANNER Test9
-./test9/test.sh $@
-$BANNER Test10
-./test10/test.sh $@
-$BANNER Test11
-./test11/test.sh $@
-$BANNER Test12
-./test12/test.sh $@
-$BANNER Test Virtual Targets
-./test_virtual/test.sh $@
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-module MA1 = A1
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-#load "discard_printf.cmo";;
-#load "debug.cmo";;
-#load "unix.cma";;
-#load "str.cma";;
-#load "my_unix.cmo";;
-#load "bool.cmo";;
-#load "glob_ast.cmo";;
-#load "glob_lexer.cmo";;
-#load "glob.cmo";;
-#load "lexers.cmo";;
-#load "my_std.cmo";;
-#load "tags.cmo";;
+++ /dev/null
-#########################################################################
-# #
-# OCaml #
-# #
-# Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt #
-# #
-# Copyright 2007 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-#!/bin/sh
-set -e
-set -x
-cd `dirname $0`/../..
-$OCB -quiet -build-dir _buildtest -no-links test/test9/testglob.native
-./_buildtest/test/test9/testglob.native
+++ /dev/null
-#########################################################################
-# #
-# OCaml #
-# #
-# Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt #
-# #
-# Copyright 2007 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-# a comment
-"a/aa.byte" or "a/aa.native": use_libb
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-let bar = 3 + List.length Bb.foo
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-val bar : int
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-let foo = [2.2]
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-open Ocamlbuild_plugin;;
-dispatch begin function
-| After_rules -> ocaml_lib "b/libb"
-| _ -> ()
-end
+++ /dev/null
-#########################################################################
-# #
-# OCaml #
-# #
-# Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt #
-# #
-# Copyright 2007 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-#!/bin/sh
-cd `dirname $0`
-set -e
-set -x
-CMDOTPS="" # -- command args
-BUILD="$OCB -I a -I b aa.byte aa.native -no-skip -classic-display $@"
-BUILD1="$BUILD $CMDOPTS"
-BUILD2="$BUILD -verbose 0 -nothing-should-be-rebuilt $CMDOPTS"
-rm -rf _build
-$BUILD1
-echo looks if libs are there
-ls _build/b/libb.cma _build/b/libb.cmxa _build/b/libb.a
-$BUILD2
+++ /dev/null
-#########################################################################
-# #
-# OCaml #
-# #
-# Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt #
-# #
-# Copyright 2007 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-"vivi.ml": camlp4o
-
-# , some_useless_tag, \ more_useless_tags
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-let tata = "TATA2"
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* a comment *)
-val tata : string
+++ /dev/null
-#########################################################################
-# #
-# OCaml #
-# #
-# Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt #
-# #
-# Copyright 2007 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-#!/bin/sh
-cd `dirname $0`
-set -e
-set -x
-CMDOPTS="-- -help"
-BUILD="$OCB toto.byte toto.native -no-skip -classic-display $@"
-BUILD1="$BUILD $CMDOPTS"
-BUILD2="$BUILD -verbose 0 -nothing-should-be-rebuilt $CMDOPTS"
-rm -rf _build
-cp vivi1.ml vivi.ml
-$BUILD1
-$BUILD2
-cp vivi2.ml vivi.ml
-$BUILD1
-$BUILD2
-cp vivi3.ml vivi.ml
-$BUILD1
-$BUILD2
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-let titi = []
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-let i = Tutu.tutu + 10
-let s = Tata.tata ^ ".ml"
-let l = 3 :: Titi.titi
-let () = Format.printf "toto.native: %s: Hello world!!!@." Sys.argv.(0)
-let () = Format.printf "Tutu.tutu => %d@.Tata.tata => %S@." Tutu.tutu Tata.tata
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-let tutu = (Array.length Vivi.vivi : Tyty.t)
-let tutu' = 2.0 +. float_of_int tutu
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* a comment *)
-val tutu : int
-val tutu' : float
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-type t = int
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-let rec p i = [< '1; '2; p (i + 1) >]
-let vivi = [|2|]
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-let rec p i = [< '1; '2; p (i + 1) >]
-let vivi = [|3|]
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-let rec p i = [< '1; '2; p (i + 1) >]
-let vivi = [|2.1; 1.1|]
+++ /dev/null
-#########################################################################
-# #
-# OCaml #
-# #
-# Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt #
-# #
-# Copyright 2007 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-"a.byte" or "a.native": use_unix
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-module X = B
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* Nothing *)
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-module X = C
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* nothing *)
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-module X = D
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* nothing *)
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-module X = E
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* nothing *)
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-module X = F
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* nothing *)
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* nothing *)
-let _ = Unix.stat
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* nothing *)
+++ /dev/null
-A B C D E F
+++ /dev/null
-#########################################################################
-# #
-# OCaml #
-# #
-# Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt #
-# #
-# Copyright 2007 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-#!/bin/sh
-cd `dirname $0`
-set -e
-set -x
-CMDOTPS="" # -- command args
-BUILD="$OCB a.byte a.native proj.docdir/index.html -no-skip -classic-display $@"
-BUILD1="$BUILD $CMDOPTS"
-BUILD2="$BUILD -verbose 0 -nothing-should-be-rebuilt $CMDOPTS"
-rm -rf _build
-$BUILD1
-$BUILD2
+++ /dev/null
-#########################################################################
-# #
-# OCaml #
-# #
-# Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt #
-# #
-# Copyright 2007 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-# a comment
-"a/aa.byte" or "a/aa.native": use_str
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-let bar = 3 + List.length Bb.foo
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-val bar : int
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-let r = Str.regexp "r"
-let foo = [2.2]
+++ /dev/null
-#########################################################################
-# #
-# OCaml #
-# #
-# Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt #
-# #
-# Copyright 2007 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-#!/bin/sh
-cd `dirname $0`
-set -e
-set -x
-CMDOTPS="" # -- command args
-BUILD="$OCB -I a -I b aa.byte aa.native -no-skip -classic-display $@"
-BUILD1="$BUILD $CMDOPTS"
-BUILD2="$BUILD -verbose 0 -nothing-should-be-rebuilt $CMDOPTS"
-rm -rf _build
-$BUILD1
-$BUILD2
+++ /dev/null
-#########################################################################
-# #
-# OCaml #
-# #
-# Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt #
-# #
-# Copyright 2007 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-"a.cmx" or "b.cmx": for-pack(C)
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-let a = 42 + Stack.stack
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-val a : int
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-let b = A.a + 1
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-Format.printf "C.B.b = %d@." C.B.b
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-let stack = 42
+++ /dev/null
-#########################################################################
-# #
-# OCaml #
-# #
-# Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt #
-# #
-# Copyright 2007 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-#!/bin/sh
-cd `dirname $0`
-set -e
-set -x
-CMDOPTS="" # -- command args
-BUILD="$OCB d.byte d.native -no-skip -classic-display $@"
-BUILD1="$BUILD $CMDOPTS"
-BUILD2="$BUILD -verbose 0 -nothing-should-be-rebuilt $CMDOPTS"
-rm -rf _build
-$BUILD1
-$BUILD2
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-let a = B.b
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-val a : 'a -> 'a
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-let b = D.d
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-val b : 'a -> 'a
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-val b : 'a -> 'a
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-....
-val b : 'a -> 'a
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-type t
-let d x = x
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-val d : 'a -> 'a
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-type t
-val d : 'a -> 'a
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-val d : 'a -> 'a
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-A.a 2. +. D.d 1.
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* nothing *)
+++ /dev/null
-#########################################################################
-# #
-# OCaml #
-# #
-# Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt #
-# #
-# Copyright 2007 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-#!/bin/sh
-cd `dirname $0`
-set -x
-rm -rf _build
-CMDOPTS="" # -- command args
-BUILD="$OCB -no-skip main.byte -classic-display $@"
-BUILD1="$BUILD $CMDOPTS"
-BUILD2="$BUILD -verbose 0 -nothing-should-be-rebuilt $CMDOPTS"
-cp b.mli.v1 b.mli
-cp d.mli.v1 d.mli
-$BUILD1
-$BUILD2
-cp b.mli.v2 b.mli
-cp d.mli.v2 d.mli
-$BUILD1
-cp b.mli.v1 b.mli
-if $BUILD1; then
- if $BUILD2; then
- echo PASS
- else
- echo "FAIL (-nothing-should-be-rebuilt)"
- fi
-else
- echo FAIL
-fi
+++ /dev/null
-#########################################################################
-# #
-# OCaml #
-# #
-# Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt #
-# #
-# Copyright 2007 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-"main.byte": my_cool_plugin
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-let aa = "aa"
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-val bb : int
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-let bb = 43
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-let bb = 43
-let f x = x + 1
-let () = incr (ref 0)
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-let bb = 43
-let f x = x + 1
-let () = incr (ref 1)
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-let c2 = 12
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-val c2 : int
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-let c3 = Bb.bb + 13
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-let cc = (String.length Aa.aa) + Bb.bb + C2.c2
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-print_endline "I am a cool plugin"
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-let main = String.length Aa.aa - Bb.bb - C3.c3 - Cc.cc - 1
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-open Ocamlbuild_plugin;;
-dispatch begin function
-| After_rules ->
- use_lib "main" "bbcc";
- dep ["ocaml"; "link"; "byte"; "my_cool_plugin"] ["cool_plugin.cmo"];
-| _ -> ()
-end
+++ /dev/null
-#########################################################################
-# #
-# OCaml #
-# #
-# Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt #
-# #
-# Copyright 2007 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-#!/bin/sh
-cd `dirname $0`
-set -e
-set -x
-CMDOPTS="" # -- command args
-BUILD="$OCB bbcc.cma main.byte bbcc.cmxa main.native -no-skip -classic-display $@"
-BUILD1="$BUILD $CMDARGS"
-BUILD2="$BUILD -verbose 0 -nothing-should-be-rebuilt $CMDARGS"
-rm -rf _build
-cp bb1.ml bb.ml
-$BUILD1
-$BUILD2
-cp bb2.ml bb.ml
-$BUILD1 -verbose 0
-$BUILD2
-cp bb3.ml bb.ml
-$BUILD1 -verbose 0
-$BUILD2
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-print_endline Myconfig.version;;
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-open Ocamlbuild_plugin;;
-let version = "0.1";;
-dispatch begin function
- | After_rules ->
- rule "myconfig.ml"
- ~prod:"myconfig.ml"
- begin fun _ _ ->
- Echo(["let version = \""; version; "\";;\n"], "myconfig.ml")
- end;
-
- copy_rule "copy byte-code executables" "%(path).byte" "%(path:not <**/*.*>)";
- copy_rule "copy native executables" "%(path).native" "%(path:not <**/*.*>).opt";
- copy_rule "copy binaries to bin" "%(basename).%(extension)"
- "bin/%(basename).%(extension:<{byte,native}>)";
- | _ -> ()
-end
+++ /dev/null
-#########################################################################
-# #
-# OCaml #
-# #
-# Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt #
-# #
-# Copyright 2007 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-#!/bin/sh
-cd `dirname $0`
-set -e
-set -x
-CMDOPTS="" # -- command args
-BUILD="$OCB a.byte a.native a a.opt bin/a bin/a.opt -no-skip -classic-display $@"
-BUILD1="$BUILD $CMDOPTS"
-BUILD2="$BUILD -verbose 0 -nothing-should-be-rebuilt $CMDOPTS"
-rm -rf _build
-$BUILD1
-$BUILD2
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-#load "unix.cma";;
-#load "str.cma";;
-#load "discard_printf.cmo";;
-#load "debug.cmo";;
-#load "bool.cmo";;
-#load "glob_ast.cmo";;
-#load "glob_lexer.cmo";;
-#load "my_unix.cmo";;
-#use "glob.ml";;
-#install_printer print_is;;
+++ /dev/null
-#########################################################################
-# #
-# OCaml #
-# #
-# Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt #
-# #
-# Copyright 2007 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-#!/bin/sh
-set -e
-set -x
-cd `dirname $0`/../..
-$OCB -quiet -build-dir _buildtest -no-links test/test9/testglob.native $@
-./_buildtest/test/test9/testglob.native
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* Testglob *)
-
-open Bool;;
-open Glob;;
-
-let yep f x =
- try
- ignore (f x);
- true
- with
- | _ -> false
-;;
-
-let tests1 = [
- "\"hello\"", true;
- "<hello>", true;
- "<hel*lo>", true;
- "<a> and <b> or <c>", true;
- "<a> titi", false
-];;
-
-let tests2 = [
- "<[a]>", ["a"], ["b"];
- "<[a-z]>", ["a";"e";"k";"z"], ["0";"A";"~"];
- "<[a-z][0-9]>", ["a0";"b9"], ["a00";"a0a";"b0a";"isduis";""];
- "<hello>", ["hello"], ["helli"];
- "\"hello\"", ["hello"], ["heidi"];
- "<*>", ["";"a";"ax"], [];
- "<a*b>", ["ab";"acb";"axxxxxb";"ababbababb"], ["abx";"xxxxxab";"xab"];
- "<*.ml>", ["hello.ml";".ml"], ["ml"; ""; "toto.mli"];
- "<a>", ["a"], ["";"aa";"ba";"ab";"abaa"];
- "<ab>", ["ab"], ["";"abab";"aba";"abx"];
- "<ab?c>", ["abac";"abxc"], ["abab";"ababab";"ababa"];
- "<*ab?cd*>", ["123abecd345";"abccd";"abccd345";"ababcababccdab"], ["abcd";"aaaaabcdababcd"];
- "<*this*is*a*test*>", ["this is a test";"You know this is a test really";"thisisatest"], ["thisatest"];
- "<b*>", ["bxx";"bx"], ["aaab";""];
- "<*>", ["";"a";"aaa";"aaaaa"], [];
- "<?>", ["a"],["";"aaa";"aaaaa"];
- "<{a,b}>", ["a";"b"],["";"aa";"ab";"ba";"bb";"c"];
- "<toto.{ml,mli}>", ["toto.ml";"toto.mli"],["toto.";"toto.mll"];
- "<{a,b}{c,[de]}{f,g}>", ["acf";"acg";"adf";"adg";"aef";"aeg";"bcf";"bcg";"bdf";"bdg";"bef";"beg"],
- ["afg";"af";"aee"];
- "(<*.ml> or <*.mli>) and not \"hello.ml\"",
- ["a.ml"; "b.ml"; "a.mli"],
- ["hello.ml"; "a.mli.x"];
- "<*>", ["alpha";"beta"], ["alpha/beta";"gamma/delta"];
- "<alpha/**/beta>", ["alpha/beta";"alpha/gamma/beta";"alpha/gamma/delta/beta"],
- ["alpha";"beta";"gamma/delta"];
- "<**/*.ml>", ["toto.ml";"toto/tata.ml";"alpha/gamma/delta/beta.ml"],
- ["toto.mli"];
- "<toto/**>", ["toto/";"toto/tata";"toto/alpha/gamma/delta/beta.ml";"toto"],
- ["toto2/tata"; "tata/titi"]
-];;
-
-let tests3 = [
- "%(path:<**/>)lib%(libname:<*> and not <*.*>).a",
- ["libfoo.a","","foo";
- "src/bar/libfoo.a","src/bar/","foo";
- "otherlibs/unix/libunix.a","otherlibs/unix/","unix";
- "otherlibsliblib/unlibix/libunix.a","otherlibsliblib/unlibix/","unix";
- "libfoo/libbar.a","libfoo/","bar";
- "src/libfoo/boo/libbar.a","src/libfoo/boo/","bar";
- ],
- ["bar"; "libbar/foo.a"; "libfoo.b.a"]
-];;
-
-let _ =
- let times = 3 in
- List.iter
- begin fun (str, ast) ->
- let ast' = yep Glob.parse str in
- if ast <> ast' then
- begin
- Printf.printf "Globexp parsing failed for %S.\n%!" str;
- exit 1
- end
- else
- Printf.printf "Globexp for %S OK\n%!" str
- end
- tests1;
- List.iter
- begin fun (gstr, yes, no) ->
- let globber = Glob.parse gstr in
- let check polarity =
- List.iter
- begin fun y ->
- if Glob.eval globber y = polarity then
- Printf.printf "Glob.eval %S %S = %b OK\n%!" gstr y polarity
- else
- begin
- Printf.printf "Glob.eval %S %S = %b FAIL\n%!" gstr y (not polarity);
- exit 1
- end
- end
- in
- for k = 1 to times do
- check true yes;
- check false no
- done
- end
- tests2;
- List.iter begin fun (str, yes, no) ->
- let resource = Resource.import_pattern str in
- for k = 1 to times do
- List.iter begin fun (y, path, libname) ->
- let resource' = Resource.import y in
- match Resource.matchit resource resource' with
- | Some env ->
- let path' = Resource.subst env "%(path)" in
- let libname' = Resource.subst env "%(libname)" in
- if path' = path && libname = libname' then
- Printf.printf "Resource.matchit %S %S OK\n%!" str y
- else begin
- Printf.printf "Resource.matchit %S %S FAIL\n%!" str y;
- exit 1
- end
- | None ->
- begin
- Printf.printf "Resource.matchit %S %S = None FAIL\n%!" str y;
- exit 1
- end
- end yes;
- List.iter begin fun y ->
- let resource' = Resource.import y in
- if Resource.matchit resource resource' = None then
- Printf.printf "Resource.matchit %S %S = None OK\n%!" str y
- else begin
- Printf.printf "Resource.matchit %S %S <> None FAIL\n%!" str y;
- exit 1
- end
- end no
- done
- end tests3
-;;
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* ocamlbuild *)
-(* *)
-(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2007 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-open Ocamlbuild_plugin;;
-dispatch begin function
- | After_rules ->
- rule "copy foo"
- ~prod:"bar"
- ~dep:"foo.otarget"
- begin fun _env _build ->
- cp "foo" "bar"
- end
- | _ -> ()
-end
+++ /dev/null
-#########################################################################
-# #
-# OCaml #
-# #
-# Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt #
-# #
-# Copyright 2007 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-#!/bin/sh
-cd `dirname $0`
-set -e
-set -x
-CMDOPTS="" # -- command args
-BUILD="$OCB bar -no-skip -classic-display $@"
-BUILD1="$BUILD $CMDOPTS"
-BUILD2="$BUILD -verbose 0 -nothing-should-be-rebuilt $CMDOPTS"
-rm -rf _build
-cp foo1 foo
-$BUILD1
-$BUILD2
-cp foo2 foo
-$BUILD1 -verbose 0
-$BUILD2
-rm foo
projects / ocaml.git / commitdiff