From 4ad5ce933da9ad578817c63fb3aa53d5f3d3384d Mon Sep 17 00:00:00 2001 From: Stephane Glondu Date: Fri, 19 Jun 2015 17:59:12 +0200 Subject: [PATCH] Imported Upstream version 4.02.2 --- VERSION | 2 +- boot/ocamlc | Bin 1745784 -> 1745774 bytes boot/ocamldep | Bin 556857 -> 556847 bytes boot/ocamllex | Bin 256437 -> 256423 bytes compilerlibs/.gitignore | 0 experimental/doligez/check-bounds.diff | 149 -- experimental/doligez/checkheaders | 152 -- experimental/frisch/Makefile | 79 - experimental/frisch/copy_typedef.ml | 181 -- experimental/frisch/eval.ml | 141 - experimental/frisch/extension_points.txt | 740 ------ experimental/frisch/ifdef.ml | 118 - experimental/frisch/js_syntax.ml | 112 - experimental/frisch/metaquot_test.ml | 27 - experimental/frisch/minidoc.ml | 72 - experimental/frisch/nomli.ml | 114 - experimental/frisch/ppx_builder.ml | 100 - experimental/frisch/ppx_matches.ml | 29 - experimental/frisch/test_builder.ml | 19 - experimental/frisch/test_copy_typedef.ml | 19 - experimental/frisch/test_copy_typedef.mli | 20 - experimental/frisch/test_eval.ml | 37 - experimental/frisch/test_ifdef.ml | 25 - experimental/frisch/test_js.ml | 22 - experimental/frisch/test_matches.ml | 3 - experimental/frisch/test_nomli.ml | 30 - experimental/frisch/testdoc.mli | 29 - experimental/frisch/unused_exported_values.ml | 63 - experimental/garrigue/.cvsignore | 2 - experimental/garrigue/caml_set_oid.diff | 141 - experimental/garrigue/coerce.diff | 93 - experimental/garrigue/countchars.ml | 16 - experimental/garrigue/dirs_multimatch | 1 - experimental/garrigue/dirs_poly | 1 - experimental/garrigue/fixedtypes.ml | 77 - experimental/garrigue/gadt-escape-check.diff | 519 ---- .../garrigue/generative-functors.diff | 1008 ------- experimental/garrigue/impure-functors.diff | 223 -- experimental/garrigue/marshal_objects.diff | 800 ------ experimental/garrigue/module-errors.diff | 403 --- experimental/garrigue/multimatch.diff | 1418 ---------- experimental/garrigue/multimatch.ml | 158 -- experimental/garrigue/newlabels.ps | 1458 ---------- experimental/garrigue/nongeneral-let.diff | 428 --- experimental/garrigue/objvariant.diff | 354 --- experimental/garrigue/objvariant.ml | 42 - experimental/garrigue/parser-lessminus.diff | 77 - .../garrigue/pattern-local-types.diff | 467 ---- experimental/garrigue/printers.ml | 11 - .../garrigue/propagation-to-patterns.diff | 212 -- experimental/garrigue/show_types.diff | 419 --- experimental/garrigue/tests.ml | 22 - experimental/garrigue/valvirt.diff | 2349 ----------------- .../garrigue/variable-names-Tvar.diff | 1656 ------------ experimental/garrigue/variable-names.ml | 4 - experimental/garrigue/varunion.ml | 435 --- experimental/garrigue/with-module-type.diff | 530 ---- ocamlbuild/test/good-output | 1473 ----------- ocamlbuild/test/runtest.sh | 56 - ocamlbuild/test/test1/foo.ml | 13 - ocamlbuild/test/test10/dbdi | 24 - ocamlbuild/test/test10/test.sh | 18 - ocamlbuild/test/test11/_tags | 14 - ocamlbuild/test/test11/a/aa.ml | 13 - ocamlbuild/test/test11/a/aa.mli | 13 - ocamlbuild/test/test11/b/bb.ml | 13 - ocamlbuild/test/test11/b/libb.mllib | 1 - ocamlbuild/test/test11/myocamlbuild.ml | 17 - ocamlbuild/test/test11/test.sh | 25 - ocamlbuild/test/test2/_tags | 15 - ocamlbuild/test/test2/tata.ml | 13 - ocamlbuild/test/test2/tata.mli | 14 - ocamlbuild/test/test2/test.sh | 30 - ocamlbuild/test/test2/titi.ml | 13 - ocamlbuild/test/test2/toto.ml | 17 - ocamlbuild/test/test2/tutu.ml | 14 - ocamlbuild/test/test2/tutu.mli | 15 - ocamlbuild/test/test2/tyty.mli | 13 - ocamlbuild/test/test2/vivi1.ml | 14 - ocamlbuild/test/test2/vivi2.ml | 14 - ocamlbuild/test/test2/vivi3.ml | 14 - ocamlbuild/test/test3/_tags | 13 - ocamlbuild/test/test3/a.ml | 13 - ocamlbuild/test/test3/a.mli | 13 - ocamlbuild/test/test3/b.ml | 13 - ocamlbuild/test/test3/b.mli | 13 - ocamlbuild/test/test3/c.ml | 13 - ocamlbuild/test/test3/c.mli | 13 - ocamlbuild/test/test3/d.ml | 13 - ocamlbuild/test/test3/d.mli | 13 - ocamlbuild/test/test3/e.ml | 13 - ocamlbuild/test/test3/e.mli | 13 - ocamlbuild/test/test3/f.ml | 14 - ocamlbuild/test/test3/f.mli | 13 - ocamlbuild/test/test3/proj.odocl | 1 - ocamlbuild/test/test3/test.sh | 23 - ocamlbuild/test/test4/_tags | 14 - ocamlbuild/test/test4/a/aa.ml | 13 - ocamlbuild/test/test4/a/aa.mli | 13 - ocamlbuild/test/test4/b/bb.ml | 14 - ocamlbuild/test/test4/test.sh | 23 - ocamlbuild/test/test5/_tags | 13 - ocamlbuild/test/test5/a.ml | 13 - ocamlbuild/test/test5/a.mli | 13 - ocamlbuild/test/test5/b.ml | 13 - ocamlbuild/test/test5/c.mlpack | 1 - ocamlbuild/test/test5/d.ml | 13 - ocamlbuild/test/test5/stack.ml | 13 - ocamlbuild/test/test5/test.sh | 23 - ocamlbuild/test/test6/a.ml | 13 - ocamlbuild/test/test6/a.mli | 13 - ocamlbuild/test/test6/b.ml | 13 - ocamlbuild/test/test6/b.mli | 13 - ocamlbuild/test/test6/b.mli.v1 | 13 - ocamlbuild/test/test6/b.mli.v2 | 14 - ocamlbuild/test/test6/d.ml | 14 - ocamlbuild/test/test6/d.mli | 13 - ocamlbuild/test/test6/d.mli.v1 | 14 - ocamlbuild/test/test6/d.mli.v2 | 13 - ocamlbuild/test/test6/main.ml | 13 - ocamlbuild/test/test6/main.mli | 13 - ocamlbuild/test/test6/test.sh | 37 - ocamlbuild/test/test7/_tags | 13 - ocamlbuild/test/test7/aa.ml | 13 - ocamlbuild/test/test7/bb.mli | 13 - ocamlbuild/test/test7/bb1.ml | 13 - ocamlbuild/test/test7/bb2.ml | 15 - ocamlbuild/test/test7/bb3.ml | 15 - ocamlbuild/test/test7/bbcc.mllib | 1 - ocamlbuild/test/test7/c2.ml | 13 - ocamlbuild/test/test7/c2.mli | 13 - ocamlbuild/test/test7/c3.ml | 13 - ocamlbuild/test/test7/cc.ml | 13 - ocamlbuild/test/test7/cool_plugin.ml | 13 - ocamlbuild/test/test7/main.ml | 13 - ocamlbuild/test/test7/myocamlbuild.ml | 19 - ocamlbuild/test/test7/test.sh | 30 - ocamlbuild/test/test8/a.ml | 13 - ocamlbuild/test/test8/myocamlbuild.ml | 28 - ocamlbuild/test/test8/test.sh | 23 - ocamlbuild/test/test9/dbgl | 22 - ocamlbuild/test/test9/test.sh | 18 - ocamlbuild/test/test9/testglob.ml | 146 - ocamlbuild/test/test_virtual/foo.itarget | 1 - ocamlbuild/test/test_virtual/foo1 | 1 - ocamlbuild/test/test_virtual/foo2 | 1 - ocamlbuild/test/test_virtual/myocamlbuild.ml | 23 - ocamlbuild/test/test_virtual/test.sh | 28 - 148 files changed, 1 insertion(+), 18555 deletions(-) delete mode 100644 compilerlibs/.gitignore delete mode 100644 experimental/doligez/check-bounds.diff delete mode 100755 experimental/doligez/checkheaders delete mode 100644 experimental/frisch/Makefile delete mode 100644 experimental/frisch/copy_typedef.ml delete mode 100644 experimental/frisch/eval.ml delete mode 100644 experimental/frisch/extension_points.txt delete mode 100644 experimental/frisch/ifdef.ml delete mode 100644 experimental/frisch/js_syntax.ml delete mode 100644 experimental/frisch/metaquot_test.ml delete mode 100644 experimental/frisch/minidoc.ml delete mode 100644 experimental/frisch/nomli.ml delete mode 100644 experimental/frisch/ppx_builder.ml delete mode 100644 experimental/frisch/ppx_matches.ml delete mode 100644 experimental/frisch/test_builder.ml delete mode 100644 experimental/frisch/test_copy_typedef.ml delete mode 100644 experimental/frisch/test_copy_typedef.mli delete mode 100644 experimental/frisch/test_eval.ml delete mode 100644 experimental/frisch/test_ifdef.ml delete mode 100644 experimental/frisch/test_js.ml delete mode 100644 experimental/frisch/test_matches.ml delete mode 100644 experimental/frisch/test_nomli.ml delete mode 100644 experimental/frisch/testdoc.mli delete mode 100644 experimental/frisch/unused_exported_values.ml delete mode 100644 experimental/garrigue/.cvsignore delete mode 100644 experimental/garrigue/caml_set_oid.diff delete mode 100644 experimental/garrigue/coerce.diff delete mode 100644 experimental/garrigue/countchars.ml delete mode 100644 experimental/garrigue/dirs_multimatch delete mode 100644 experimental/garrigue/dirs_poly delete mode 100644 experimental/garrigue/fixedtypes.ml delete mode 100644 experimental/garrigue/gadt-escape-check.diff delete mode 100644 experimental/garrigue/generative-functors.diff delete mode 100644 experimental/garrigue/impure-functors.diff delete mode 100644 experimental/garrigue/marshal_objects.diff delete mode 100644 experimental/garrigue/module-errors.diff delete mode 100644 experimental/garrigue/multimatch.diff delete mode 100644 experimental/garrigue/multimatch.ml delete mode 100644 experimental/garrigue/newlabels.ps delete mode 100644 experimental/garrigue/nongeneral-let.diff delete mode 100644 experimental/garrigue/objvariant.diff delete mode 100644 experimental/garrigue/objvariant.ml delete mode 100644 experimental/garrigue/parser-lessminus.diff delete mode 100644 experimental/garrigue/pattern-local-types.diff delete mode 100644 experimental/garrigue/printers.ml delete mode 100644 experimental/garrigue/propagation-to-patterns.diff delete mode 100644 experimental/garrigue/show_types.diff delete mode 100644 experimental/garrigue/tests.ml delete mode 100644 experimental/garrigue/valvirt.diff delete mode 100644 experimental/garrigue/variable-names-Tvar.diff delete mode 100644 experimental/garrigue/variable-names.ml delete mode 100644 experimental/garrigue/varunion.ml delete mode 100644 experimental/garrigue/with-module-type.diff delete mode 100644 ocamlbuild/test/good-output delete mode 100755 ocamlbuild/test/runtest.sh delete mode 100644 ocamlbuild/test/test1/foo.ml delete mode 100644 ocamlbuild/test/test10/dbdi delete mode 100755 ocamlbuild/test/test10/test.sh delete mode 100644 ocamlbuild/test/test11/_tags delete mode 100644 ocamlbuild/test/test11/a/aa.ml delete mode 100644 ocamlbuild/test/test11/a/aa.mli delete mode 100644 ocamlbuild/test/test11/b/bb.ml delete mode 100644 ocamlbuild/test/test11/b/libb.mllib delete mode 100644 ocamlbuild/test/test11/myocamlbuild.ml delete mode 100755 ocamlbuild/test/test11/test.sh delete mode 100644 ocamlbuild/test/test2/_tags delete mode 100644 ocamlbuild/test/test2/tata.ml delete mode 100644 ocamlbuild/test/test2/tata.mli delete mode 100755 ocamlbuild/test/test2/test.sh delete mode 100644 ocamlbuild/test/test2/titi.ml delete mode 100644 ocamlbuild/test/test2/toto.ml delete mode 100644 ocamlbuild/test/test2/tutu.ml delete mode 100644 ocamlbuild/test/test2/tutu.mli delete mode 100644 ocamlbuild/test/test2/tyty.mli delete mode 100644 ocamlbuild/test/test2/vivi1.ml delete mode 100644 ocamlbuild/test/test2/vivi2.ml delete mode 100644 ocamlbuild/test/test2/vivi3.ml delete mode 100644 ocamlbuild/test/test3/_tags delete mode 100644 ocamlbuild/test/test3/a.ml delete mode 100644 ocamlbuild/test/test3/a.mli delete mode 100644 ocamlbuild/test/test3/b.ml delete mode 100644 ocamlbuild/test/test3/b.mli delete mode 100644 ocamlbuild/test/test3/c.ml delete mode 100644 ocamlbuild/test/test3/c.mli delete mode 100644 ocamlbuild/test/test3/d.ml delete mode 100644 ocamlbuild/test/test3/d.mli delete mode 100644 ocamlbuild/test/test3/e.ml delete mode 100644 ocamlbuild/test/test3/e.mli delete mode 100644 ocamlbuild/test/test3/f.ml delete mode 100644 ocamlbuild/test/test3/f.mli delete mode 100644 ocamlbuild/test/test3/proj.odocl delete mode 100755 ocamlbuild/test/test3/test.sh delete mode 100644 ocamlbuild/test/test4/_tags delete mode 100644 ocamlbuild/test/test4/a/aa.ml delete mode 100644 ocamlbuild/test/test4/a/aa.mli delete mode 100644 ocamlbuild/test/test4/b/bb.ml delete mode 100755 ocamlbuild/test/test4/test.sh delete mode 100644 ocamlbuild/test/test5/_tags delete mode 100644 ocamlbuild/test/test5/a.ml delete mode 100644 ocamlbuild/test/test5/a.mli delete mode 100644 ocamlbuild/test/test5/b.ml delete mode 100644 ocamlbuild/test/test5/c.mlpack delete mode 100644 ocamlbuild/test/test5/d.ml delete mode 100644 ocamlbuild/test/test5/stack.ml delete mode 100755 ocamlbuild/test/test5/test.sh delete mode 100644 ocamlbuild/test/test6/a.ml delete mode 100644 ocamlbuild/test/test6/a.mli delete mode 100644 ocamlbuild/test/test6/b.ml delete mode 100644 ocamlbuild/test/test6/b.mli delete mode 100644 ocamlbuild/test/test6/b.mli.v1 delete mode 100644 ocamlbuild/test/test6/b.mli.v2 delete mode 100644 ocamlbuild/test/test6/d.ml delete mode 100644 ocamlbuild/test/test6/d.mli delete mode 100644 ocamlbuild/test/test6/d.mli.v1 delete mode 100644 ocamlbuild/test/test6/d.mli.v2 delete mode 100644 ocamlbuild/test/test6/main.ml delete mode 100644 ocamlbuild/test/test6/main.mli delete mode 100755 ocamlbuild/test/test6/test.sh delete mode 100644 ocamlbuild/test/test7/_tags delete mode 100644 ocamlbuild/test/test7/aa.ml delete mode 100644 ocamlbuild/test/test7/bb.mli delete mode 100644 ocamlbuild/test/test7/bb1.ml delete mode 100644 ocamlbuild/test/test7/bb2.ml delete mode 100644 ocamlbuild/test/test7/bb3.ml delete mode 100644 ocamlbuild/test/test7/bbcc.mllib delete mode 100644 ocamlbuild/test/test7/c2.ml delete mode 100644 ocamlbuild/test/test7/c2.mli delete mode 100644 ocamlbuild/test/test7/c3.ml delete mode 100644 ocamlbuild/test/test7/cc.ml delete mode 100644 ocamlbuild/test/test7/cool_plugin.ml delete mode 100644 ocamlbuild/test/test7/main.ml delete mode 100644 ocamlbuild/test/test7/myocamlbuild.ml delete mode 100755 ocamlbuild/test/test7/test.sh delete mode 100644 ocamlbuild/test/test8/a.ml delete mode 100644 ocamlbuild/test/test8/myocamlbuild.ml delete mode 100755 ocamlbuild/test/test8/test.sh delete mode 100644 ocamlbuild/test/test9/dbgl delete mode 100755 ocamlbuild/test/test9/test.sh delete mode 100644 ocamlbuild/test/test9/testglob.ml delete mode 100644 ocamlbuild/test/test_virtual/foo.itarget delete mode 100644 ocamlbuild/test/test_virtual/foo1 delete mode 100644 ocamlbuild/test/test_virtual/foo2 delete mode 100644 ocamlbuild/test/test_virtual/myocamlbuild.ml delete mode 100755 ocamlbuild/test/test_virtual/test.sh diff --git a/VERSION b/VERSION index 7fb240e1..4936d848 100644 --- a/VERSION +++ b/VERSION @@ -1,4 +1,4 @@ -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 diff --git a/boot/ocamlc b/boot/ocamlc index a70f3df7845ccd7f9921d1fa4d69138b187d3e07..9cd42cfeaf34689279bc356d6d77c2748291a939 100755 GIT binary patch delta 162 zcmexyEbHB|tO>e|dW|}*I*hG4OszW1tvW2NI;^caY^^%%tvVd7I-IRKT&+6XtvWod zI=rnqe62eCtvUj&I)be_LajQ&tvVvDI-*;3#8zzOUBkfOW5U2VcM1cenauWwTg8l6 z*wsw*42<-QwrlMY(~xE~pFaDlm^P!{^xCUpvW!+xUi;CjVn8eo#1h+&UX`45mhr&! Ih{aM00Fys7w*UYD delta 172 zcmW;8yAHun00!V5_xs(cTf``7j=ycR@etxESUMW)hCfD3wU`W^ps9%2#MmdWn~lWq zCExq*eeT{)tw9JPM#PB(kt9+?n#d4YB1hzj0#PJNM46}%RiZ}Ji3ZUOAkRVZqG{8y zCXNS9xc%@INIRjs(}rZ6pnU8OffQ{J*(H@<;z^ Pg}11^e~O1cJ9P$Mv>!MB diff --git a/boot/ocamldep b/boot/ocamldep index d5231c778996f38482d5e93ca5a26a1cdbac9432..a1be40085a501abefccad0dad15555f72faf5a45 100755 GIT binary patch delta 129 zcmdn_PjUS}#RlD*q)^DUSVM1ie_M#Bf!8AvuwL; zDw`1tyPAoffsvlk_Owhk6)8sZ>D|q2+VXlv`Z<|N`uWL;xj7pC&W^r5KAukMP@2;U atcX#s{ckhd_P@>S(!UvBOqZ>tVBm^oV3;Gqz!0-yyL>8} z5sSE)iJpOxo{@G+YMGg?k%6J9u7Rnpq2cz3Og0rMM$_rF&1~A!S2eTAFj|1w?O&SN Swts16m-@~4WjcR7hXMcw_9LwT diff --git a/boot/ocamllex b/boot/ocamllex index 7420b7e74b5da17dba0097f54e4e6c861a53d85f..d7a7f1e17e81b67805e9d5d07f25608a4f9011fa 100755 GIT binary patch delta 64 zcmdmbnSc3Z{t3E_dW|}*I*hG4Oj~uBkF@b7F)*;6V_;CRW?+yi*#5VT*@%T*%|y?@ UNY7}yTQ{>`9Anw^sV|uo0E5^QA^-pY delta 78 zcmZ2}nSbkL{t3E``mOqmt@=z`^_dU1@fI;Ku%2UJP_buVkSf~#zm3_5Mcm9p&%j8} iNINC9%uLtFz|d6Jz*N`JaJxk}vtJxz+w}IA%nAUp*B0Oa diff --git a/compilerlibs/.gitignore b/compilerlibs/.gitignore deleted file mode 100644 index e69de29b..00000000 diff --git a/experimental/doligez/check-bounds.diff b/experimental/doligez/check-bounds.diff deleted file mode 100644 index c2e07952..00000000 --- a/experimental/doligez/check-bounds.diff +++ /dev/null @@ -1,149 +0,0 @@ -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 - #include -+#include - #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(); -+} diff --git a/experimental/doligez/checkheaders b/experimental/doligez/checkheaders deleted file mode 100755 index 5de15329..00000000 --- a/experimental/doligez/checkheaders +++ /dev/null @@ -1,152 +0,0 @@ -#!/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 diff --git a/experimental/frisch/Makefile b/experimental/frisch/Makefile deleted file mode 100644 index 89de11f0..00000000 --- a/experimental/frisch/Makefile +++ /dev/null @@ -1,79 +0,0 @@ -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 diff --git a/experimental/frisch/copy_typedef.ml b/experimental/frisch/copy_typedef.ml deleted file mode 100644 index baf52de4..00000000 --- a/experimental/frisch/copy_typedef.ml +++ /dev/null @@ -1,181 +0,0 @@ -(* - 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 diff --git a/experimental/frisch/eval.ml b/experimental/frisch/eval.ml deleted file mode 100644 index 3940b7ea..00000000 --- a/experimental/frisch/eval.ml +++ /dev/null @@ -1,141 +0,0 @@ -(* 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 diff --git a/experimental/frisch/extension_points.txt b/experimental/frisch/extension_points.txt deleted file mode 100644 index f9d4e774..00000000 --- a/experimental/frisch/extension_points.txt +++ /dev/null @@ -1,740 +0,0 @@ -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$; - |}] diff --git a/experimental/frisch/ifdef.ml b/experimental/frisch/ifdef.ml deleted file mode 100644 index 6263b59a..00000000 --- a/experimental/frisch/ifdef.ml +++ /dev/null @@ -1,118 +0,0 @@ -(* 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 diff --git a/experimental/frisch/js_syntax.ml b/experimental/frisch/js_syntax.ml deleted file mode 100644 index fe11cb65..00000000 --- a/experimental/frisch/js_syntax.ml +++ /dev/null @@ -1,112 +0,0 @@ -(* 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 diff --git a/experimental/frisch/metaquot_test.ml b/experimental/frisch/metaquot_test.ml deleted file mode 100644 index bbdfe240..00000000 --- a/experimental/frisch/metaquot_test.ml +++ /dev/null @@ -1,27 +0,0 @@ -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 diff --git a/experimental/frisch/minidoc.ml b/experimental/frisch/minidoc.ml deleted file mode 100644 index bf37a012..00000000 --- a/experimental/frisch/minidoc.ml +++ /dev/null @@ -1,72 +0,0 @@ -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 diff --git a/experimental/frisch/nomli.ml b/experimental/frisch/nomli.ml deleted file mode 100644 index 6cf34557..00000000 --- a/experimental/frisch/nomli.ml +++ /dev/null @@ -1,114 +0,0 @@ -(** 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) - diff --git a/experimental/frisch/ppx_builder.ml b/experimental/frisch/ppx_builder.ml deleted file mode 100644 index cb866df8..00000000 --- a/experimental/frisch/ppx_builder.ml +++ /dev/null @@ -1,100 +0,0 @@ -(* - 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 diff --git a/experimental/frisch/ppx_matches.ml b/experimental/frisch/ppx_matches.ml deleted file mode 100644 index f6d95347..00000000 --- a/experimental/frisch/ppx_matches.ml +++ /dev/null @@ -1,29 +0,0 @@ -(* - 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 diff --git a/experimental/frisch/test_builder.ml b/experimental/frisch/test_builder.ml deleted file mode 100644 index 25427309..00000000 --- a/experimental/frisch/test_builder.ml +++ /dev/null @@ -1,19 +0,0 @@ -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] diff --git a/experimental/frisch/test_copy_typedef.ml b/experimental/frisch/test_copy_typedef.ml deleted file mode 100644 index cd774c69..00000000 --- a/experimental/frisch/test_copy_typedef.ml +++ /dev/null @@ -1,19 +0,0 @@ -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] diff --git a/experimental/frisch/test_copy_typedef.mli b/experimental/frisch/test_copy_typedef.mli deleted file mode 100644 index 8e137a7d..00000000 --- a/experimental/frisch/test_copy_typedef.mli +++ /dev/null @@ -1,20 +0,0 @@ -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 diff --git a/experimental/frisch/test_eval.ml b/experimental/frisch/test_eval.ml deleted file mode 100644 index c0dfc697..00000000 --- a/experimental/frisch/test_eval.ml +++ /dev/null @@ -1,37 +0,0 @@ -[%%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%!" - - diff --git a/experimental/frisch/test_ifdef.ml b/experimental/frisch/test_ifdef.ml deleted file mode 100644 index 8a18cdaa..00000000 --- a/experimental/frisch/test_ifdef.ml +++ /dev/null @@ -1,25 +0,0 @@ -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] - diff --git a/experimental/frisch/test_js.ml b/experimental/frisch/test_js.ml deleted file mode 100644 index 2582a0fb..00000000 --- a/experimental/frisch/test_js.ml +++ /dev/null @@ -1,22 +0,0 @@ -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] diff --git a/experimental/frisch/test_matches.ml b/experimental/frisch/test_matches.ml deleted file mode 100644 index a46a38ba..00000000 --- a/experimental/frisch/test_matches.ml +++ /dev/null @@ -1,3 +0,0 @@ -let l = List.filter [%matches ? 'a'..'z'] ['a';'A';'X';'x'] - -let f = [%matches ? Some i when i >= 0] diff --git a/experimental/frisch/test_nomli.ml b/experimental/frisch/test_nomli.ml deleted file mode 100644 index affa0767..00000000 --- a/experimental/frisch/test_nomli.ml +++ /dev/null @@ -1,30 +0,0 @@ -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)] diff --git a/experimental/frisch/testdoc.mli b/experimental/frisch/testdoc.mli deleted file mode 100644 index c22307ae..00000000 --- a/experimental/frisch/testdoc.mli +++ /dev/null @@ -1,29 +0,0 @@ -[@@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"] diff --git a/experimental/frisch/unused_exported_values.ml b/experimental/frisch/unused_exported_values.ml deleted file mode 100644 index 7b2d2f90..00000000 --- a/experimental/frisch/unused_exported_values.ml +++ /dev/null @@ -1,63 +0,0 @@ -(* 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 diff --git a/experimental/garrigue/.cvsignore b/experimental/garrigue/.cvsignore deleted file mode 100644 index 4539eb6d..00000000 --- a/experimental/garrigue/.cvsignore +++ /dev/null @@ -1,2 +0,0 @@ -*.out -*.out2 diff --git a/experimental/garrigue/caml_set_oid.diff b/experimental/garrigue/caml_set_oid.diff deleted file mode 100644 index aaaa160e..00000000 --- a/experimental/garrigue/caml_set_oid.diff +++ /dev/null @@ -1,141 +0,0 @@ -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 = diff --git a/experimental/garrigue/coerce.diff b/experimental/garrigue/coerce.diff deleted file mode 100644 index e90e1fc9..00000000 --- a/experimental/garrigue/coerce.diff +++ /dev/null @@ -1,93 +0,0 @@ -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 (); diff --git a/experimental/garrigue/countchars.ml b/experimental/garrigue/countchars.ml deleted file mode 100644 index 0f14d2fe..00000000 --- a/experimental/garrigue/countchars.ml +++ /dev/null @@ -1,16 +0,0 @@ -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 diff --git a/experimental/garrigue/dirs_multimatch b/experimental/garrigue/dirs_multimatch deleted file mode 100644 index 3e444000..00000000 --- a/experimental/garrigue/dirs_multimatch +++ /dev/null @@ -1 +0,0 @@ -parsing typing bytecomp driver toplevel diff --git a/experimental/garrigue/dirs_poly b/experimental/garrigue/dirs_poly deleted file mode 100644 index 60cb39f1..00000000 --- a/experimental/garrigue/dirs_poly +++ /dev/null @@ -1 +0,0 @@ -bytecomp byterun driver parsing stdlib tools toplevel typing utils diff --git a/experimental/garrigue/fixedtypes.ml b/experimental/garrigue/fixedtypes.ml deleted file mode 100644 index aa6e530e..00000000 --- a/experimental/garrigue/fixedtypes.ml +++ /dev/null @@ -1,77 +0,0 @@ -(* 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 diff --git a/experimental/garrigue/gadt-escape-check.diff b/experimental/garrigue/gadt-escape-check.diff deleted file mode 100644 index 3e4a44e2..00000000 --- a/experimental/garrigue/gadt-escape-check.diff +++ /dev/null @@ -1,519 +0,0 @@ -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 *) diff --git a/experimental/garrigue/generative-functors.diff b/experimental/garrigue/generative-functors.diff deleted file mode 100644 index c7786d11..00000000 --- a/experimental/garrigue/generative-functors.diff +++ /dev/null @@ -1,1008 +0,0 @@ -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 "@[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 "()" -+ | 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 "@[@[sig@ %a@]@ end@]" (* "@[sig@ %a@ end@]" *) - (self#list self#signature_item ) s (* FIXME wrong indentation*) -- | Pmty_functor (s, mt1, mt2) -> -+ | Pmty_functor (_, None, mt2) -> -+ pp f "@[functor () ->@ %a@]" self#module_type mt2 -+ | Pmty_functor (s, Some mt1, mt2) -> - pp f "@[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 "@[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 - diff --git a/experimental/garrigue/impure-functors.diff b/experimental/garrigue/impure-functors.diff deleted file mode 100644 index fd8dba57..00000000 --- a/experimental/garrigue/impure-functors.diff +++ /dev/null @@ -1,223 +0,0 @@ -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 "@[@[sig@ %a@]@ end@]" (* "@[sig@ %a@ end@]" *) - (self#list self#signature_item ) s (* FIXME wrong indentation*) -+ | Pmty_functor ({txt="*"}, mt1, mt2) -> -+ pp f "@[functor () ->@ %a@]" self#module_type mt2 - | Pmty_functor (s, mt1, mt2) -> - pp f "@[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 "@[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 - diff --git a/experimental/garrigue/marshal_objects.diff b/experimental/garrigue/marshal_objects.diff deleted file mode 100644 index bb9b4dd7..00000000 --- a/experimental/garrigue/marshal_objects.diff +++ /dev/null @@ -1,800 +0,0 @@ -? 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 diff --git a/experimental/garrigue/module-errors.diff b/experimental/garrigue/module-errors.diff deleted file mode 100644 index 2f8c2bc2..00000000 --- a/experimental/garrigue/module-errors.diff +++ /dev/null @@ -1,403 +0,0 @@ -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 "@[%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 "" -+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 "@[At position@ %a@]@ " context cxt -+ -+let include_err ppf (cxt, err) = -+ fprintf ppf "@[%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 "@[%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 diff --git a/experimental/garrigue/multimatch.diff b/experimental/garrigue/multimatch.diff deleted file mode 100644 index 6eb34b72..00000000 --- a/experimental/garrigue/multimatch.diff +++ /dev/null @@ -1,1418 +0,0 @@ -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 - %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 "@[`%s%t%a@]" l pr_of (print_typlist print_out_type " &") -- tyl -+ and pr_tp ppf (t1,t2) = -+ fprintf ppf "@[%a =@ %a@]" -+ print_out_type t1 -+ print_out_type t2 -+ in -+ fprintf ppf "@[`%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 "@[Reither(%b,@,%a,@,%b,@,@[<1>ref%t@])@]" c -- raw_type_list tl m -+ | Reither (c,tl,m,tpl,e) -> -+ fprintf ppf "@[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) diff --git a/experimental/garrigue/multimatch.ml b/experimental/garrigue/multimatch.ml deleted file mode 100644 index 7c9aa73f..00000000 --- a/experimental/garrigue/multimatch.ml +++ /dev/null @@ -1,158 +0,0 @@ -(* 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);; diff --git a/experimental/garrigue/newlabels.ps b/experimental/garrigue/newlabels.ps deleted file mode 100644 index 01eac194..00000000 --- a/experimental/garrigue/newlabels.ps +++ /dev/null @@ -1,1458 +0,0 @@ -%!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 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 109 D I -E -%EndDVIPSBitmapFont -%DVIPSBitmapFont: Fd cmsy8 8 3 -/Fd 3 93 df 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 78 D<03F8E00FFEE01FFFE03C07E07801E0F001E0E000E0 -E000E0E000E0E000007000007800003F80001FF80007FF00007FC00007E00000F0000070 -000038000038600038E00038E00038E00070F000F0FE01E0FFFFC0EFFF80E1FE00151E7E -9D1A> 83 D<7FFFFEFFFFFEFFFFFEE0380EE0380EE0380EE0380E003800003800003800 -003800003800003800003800003800003800003800003800003800003800003800003800 -00380000380000380000380000380003FF8003FF8003FF80171E7F9D1A> I 91 D 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 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 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 68 D<01FE0207FF861F01FE3C007E7C001E78000E78000EF80006F80006FC0006 -FC0000FF0000FFE0007FFF007FFFC03FFFF01FFFF80FFFFC03FFFE003FFE0003FE00007F -00003F00003FC0001FC0001FC0001FE0001EE0001EF0003CFC003CFF00F8C7FFE080FF80 -18227DA11F> 83 D<7FFFFFFF807FFFFFFF807E03F80F807803F807807003F803806003 -F80180E003F801C0E003F801C0C003F800C0C003F800C0C003F800C0C003F800C00003F8 -00000003F800000003F800000003F800000003F800000003F800000003F800000003F800 -000003F800000003F800000003F800000003F800000003F800000003F800000003F80000 -0003F800000003F800000003F800000003F800000003F8000001FFFFF00001FFFFF00022 -227EA127> I<0FFC003FFF807E07C07E03E07E01E07E01F03C01F00001F00001F0003FF0 -03FDF01FC1F03F01F07E01F0FC01F0FC01F0FC01F0FC01F07E02F07E0CF81FF87F07E03F -18167E951B> 97 D 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 108 -D I I<00FE0007FFC00F83E01E00F03E00F87C00 -7C7C007C7C007CFC007EFC007EFC007EFC007EFC007EFC007EFC007E7C007C7C007C3E00 -F81F01F00F83E007FFC000FE0017167E951C> I I<0FF3003FFF00781F00600700E00300E00300F00300FC00007F -E0007FF8003FFE000FFF0001FF00000F80C00780C00380E00380E00380F00700FC0E00EF -FC00C7F00011167E9516> 115 D<01800001800001800001800003800003800007800007 -80000F80003F8000FFFF00FFFF000F80000F80000F80000F80000F80000F80000F80000F -80000F80000F80000F80000F81800F81800F81800F81800F81800F830007C30003FE0000 -F80011207F9F16> I I 120 D I E -%EndDVIPSBitmapFont -%DVIPSBitmapFont: Fj cmsy10 12 15 -/Fj 15 107 df 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 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 I 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 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 61 D<07E01838201C400E800FF00FF00FF00F000F000E001C00380030006000C000C0 -00800080018001000100010001000100010000000000000000000000038007C007C007C0 -038010237DA217> 63 D<0001800000018000000180000003C0000003C0000003C00000 -05E0000005E0000009F0000008F0000008F00000107800001078000010780000203C0000 -203C0000203C0000401E0000401E0000C01F0000800F0000800F0001FFFF800100078001 -000780020003C0020003C0020003C0040001E0040001E0040001E0080000F01C0000F03E -0001F8FF800FFF20237EA225> 65 D I<0007E0100038183000E0063001C00170038000F007 -0000F00E0000701E0000701C0000303C0000303C0000307C0000107800001078000010F8 -000000F8000000F8000000F8000000F8000000F8000000F8000000F80000007800000078 -0000107C0000103C0000103C0000101C0000201E0000200E000040070000400380008001 -C0010000E0020000381C000007E0001C247DA223> I I 70 D<0007F008003C0C1800E0021801C0 -01B8038000F8070000780F0000381E0000381E0000183C0000183C0000187C0000087800 -000878000008F8000000F8000000F8000000F8000000F8000000F8000000F8000000F800 -1FFF780000F8780000787C0000783C0000783C0000781E0000781E0000780F0000780700 -0078038000B801C000B800E00318003C0C080007F00020247DA226> I I I 75 -D I -78 D<000FE00000783C0000E00E0003C00780078003C00F0001E00E0000E01E0000F03C -0000783C0000787C00007C7C00007C7800003C7800003CF800003EF800003EF800003EF8 -00003EF800003EF800003EF800003EF800003EF800003E7800003C7C00007C7C00007C3C -0000783E0000F81E0000F00F0001E00F0001E0078003C003C0078000E00E0000783C0000 -0FE0001F247DA226> I I 82 D<03F0200C0C601802603001E07000E0600060E00060E000 -60E00020E00020E00020F00000F000007800007F00003FF0001FFE000FFF0003FF80003F -C00007E00001E00000F00000F0000070800070800070800070800070C00060C00060E000 -C0F000C0C80180C6070081FC0014247DA21B> I<7FFFFFF8780780786007801840078008 -4007800840078008C007800C800780048007800480078004800780040007800000078000 -000780000007800000078000000780000007800000078000000780000007800000078000 -000780000007800000078000000780000007800000078000000780000007800000078000 -00078000000FC00001FFFE001E227EA123> I 86 D I 91 D 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 I I I I<3FFFC0380380300780200700600E -00401C00403C0040380000700000E00001E00001C0000380400700400F00400E00C01C00 -80380080780180700780FFFF8012157F9416> I 124 -D E -%EndDVIPSBitmapFont -%DVIPSBitmapFont: Fl cmbx12 14.4 19 -/Fl 19 118 df<00007FE0030007FFFC07001FFFFF0F007FF00F9F00FF0001FF01FC0000 -FF03F800007F07F000003F0FE000001F1FC000001F1FC000000F3F8000000F3F80000007 -7F800000077F800000077F00000000FF00000000FF00000000FF00000000FF00000000FF -00000000FF00000000FF00000000FF00000000FF000000007F000000007F800000007F80 -0000073F800000073F800000071FC00000071FC000000E0FE000000E07F000001C03F800 -003C01FC00007800FF0001F0007FF007C0001FFFFF800007FFFE0000007FF00028297CA8 -31> 67 D -76 D<0000FFC00000000FFFFC0000003F807F000000FE001FC00001F80007E00003F000 -03F00007E00001F8000FE00001FC001FC00000FE001FC00000FE003F8000007F003F8000 -007F007F8000007F807F0000003F807F0000003F807F0000003F80FF0000003FC0FF0000 -003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000 -003FC0FF0000003FC0FF0000003FC07F0000003F807F8000007F807F8000007F803F8000 -007F003F8000007F001FC00000FE001FC00000FE000FE00001FC0007F00003F80003F800 -07F00001FC000FE00000FE001FC000003FC0FF0000000FFFFC00000000FFC000002A297C -A833> 79 D 86 D<03FF80000FFFF0001F01FC003F80FE003F807F003F803F003F803F -801F003F8000003F8000003F8000003F8000003F80003FFF8001FC3F800FE03F801F803F -803F003F807E003F80FC003F80FC003F80FC003F80FC003F80FC005F807E00DF803F839F -FC1FFE0FFC03FC03FC1E1B7E9A21> 97 D I<00007FF000007FF000007FF0000007F0000007F0000007 -F0000007F0000007F0000007F0000007F0000007F0000007F0000007F0000007F0000007 -F0003F87F001FFF7F007F03FF00FC00FF01F8007F03F0007F03F0007F07E0007F07E0007 -F07E0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007 -F07E0007F07E0007F03F0007F03F0007F01F800FF00FC01FF007E07FFF01FFE7FF007F87 -FF202A7EA925> 100 D<003FC00001FFF00003E07C000F803E001F801F001F001F003F00 -0F807E000F807E000FC07E000FC0FE0007C0FE0007C0FFFFFFC0FFFFFFC0FE000000FE00 -0000FE0000007E0000007E0000007F0000003F0001C01F0001C00F80038007C0070003F0 -1E0000FFFC00003FE0001A1B7E9A1F> I<0007F8003FFC007E3E01FC7F03F87F03F07F07 -F07F07F03E07F00007F00007F00007F00007F00007F00007F000FFFFC0FFFFC0FFFFC007 -F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007 -F00007F00007F00007F00007F00007F00007F00007F00007F0007FFF807FFF807FFF8018 -2A7EA915> I -104 D<07000F801FC03FE03FE03FE01FC00F8007000000000000000000000000000000FF -E0FFE0FFE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00F -E00FE00FE00FE00FE00FE0FFFEFFFEFFFE0F2B7EAA12> I 108 D 110 D<003FE00001FFFC0003F07E000FC01F801F80 -0FC03F0007E03F0007E07E0003F07E0003F07E0003F0FE0003F8FE0003F8FE0003F8FE00 -03F8FE0003F8FE0003F8FE0003F8FE0003F87E0003F07E0003F03F0007E03F0007E01F80 -0FC00FC01F8007F07F0001FFFC00003FE0001D1B7E9A22> I I 114 D<03FE300FFFF03E03F078 -00F07000F0F00070F00070F80070FE0000FFE0007FFF007FFFC03FFFE01FFFF007FFF800 -FFF80007FC0000FCE0007CE0003CF0003CF00038F80038FC0070FF01E0E7FFC0C1FF0016 -1B7E9A1B> I<00E00000E00000E00000E00001E00001E00001E00003E00003E00007E000 -0FE0001FFFE0FFFFE0FFFFE00FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE000 -0FE0000FE0000FE0000FE0000FE0000FE0700FE0700FE0700FE0700FE0700FE0700FE070 -07F0E003F0C001FF80007F0014267FA51A> I 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 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 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() 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() 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() 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() 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 diff --git a/experimental/garrigue/nongeneral-let.diff b/experimental/garrigue/nongeneral-let.diff deleted file mode 100644 index bcdc69e8..00000000 --- a/experimental/garrigue/nongeneral-let.diff +++ /dev/null @@ -1,428 +0,0 @@ -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 "\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 "
  • %s
    • \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; diff --git a/experimental/garrigue/objvariant.diff b/experimental/garrigue/objvariant.diff deleted file mode 100644 index 75deb24c..00000000 --- a/experimental/garrigue/objvariant.diff +++ /dev/null @@ -1,354 +0,0 @@ -? 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@[@[%a@]%a ]@]" (if non_gen then "_" else "") -+ fprintf ppf "%s[%s@[@[%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 diff --git a/experimental/garrigue/objvariant.ml b/experimental/garrigue/objvariant.ml deleted file mode 100644 index 3233e03c..00000000 --- a/experimental/garrigue/objvariant.ml +++ /dev/null @@ -1,42 +0,0 @@ -(* 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))) diff --git a/experimental/garrigue/parser-lessminus.diff b/experimental/garrigue/parser-lessminus.diff deleted file mode 100644 index 7b535307..00000000 --- a/experimental/garrigue/parser-lessminus.diff +++ /dev/null @@ -1,77 +0,0 @@ -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 diff --git a/experimental/garrigue/pattern-local-types.diff b/experimental/garrigue/pattern-local-types.diff deleted file mode 100644 index 0e6f00a2..00000000 --- a/experimental/garrigue/pattern-local-types.diff +++ /dev/null @@ -1,467 +0,0 @@ -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 = - # val g : 'a ty -> 'a = -+# - : unit -> unit list = -+# - : 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 = -+# 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 = - # val g : 'a ty -> 'a = -+# - : unit -> unit list = -+# - : 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 = -+# 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 "\n"; -+ list (i+1) string ppf l; - pattern (i+1) ppf p; - expression (i+1) ppf e; - diff --git a/experimental/garrigue/printers.ml b/experimental/garrigue/printers.ml deleted file mode 100644 index c80c42d6..00000000 --- a/experimental/garrigue/printers.ml +++ /dev/null @@ -1,11 +0,0 @@ -(* $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 diff --git a/experimental/garrigue/propagation-to-patterns.diff b/experimental/garrigue/propagation-to-patterns.diff deleted file mode 100644 index 642d986f..00000000 --- a/experimental/garrigue/propagation-to-patterns.diff +++ /dev/null @@ -1,212 +0,0 @@ -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 - ^ diff --git a/experimental/garrigue/show_types.diff b/experimental/garrigue/show_types.diff deleted file mode 100644 index f59105ee..00000000 --- a/experimental/garrigue/show_types.diff +++ /dev/null @@ -1,419 +0,0 @@ -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 diff --git a/experimental/garrigue/tests.ml b/experimental/garrigue/tests.ml deleted file mode 100644 index c39d152f..00000000 --- a/experimental/garrigue/tests.ml +++ /dev/null @@ -1,22 +0,0 @@ -(* $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" diff --git a/experimental/garrigue/valvirt.diff b/experimental/garrigue/valvirt.diff deleted file mode 100644 index 2cf55742..00000000 --- a/experimental/garrigue/valvirt.diff +++ /dev/null @@ -1,2349 +0,0 @@ -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 ] - ; - diff --git a/experimental/garrigue/variable-names-Tvar.diff b/experimental/garrigue/variable-names-Tvar.diff deleted file mode 100644 index 99ff6a24..00000000 --- a/experimental/garrigue/variable-names-Tvar.diff +++ /dev/null @@ -1,1656 +0,0 @@ -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 "@[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 "@[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 "" - | Tarrow(_, ty1, ty2, _) -> - Oval_stuff "" -@@ -327,8 +327,6 @@ - fatal_error "Printval.outval_of_value" - | Tpoly (ty, _) -> - tree_of_val (depth - 1) obj ty -- | Tunivar -> -- Oval_stuff "" - | Tpackage _ -> - Oval_stuff "" - 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 diff --git a/experimental/garrigue/variable-names.ml b/experimental/garrigue/variable-names.ml deleted file mode 100644 index f3c7771a..00000000 --- a/experimental/garrigue/variable-names.ml +++ /dev/null @@ -1,4 +0,0 @@ -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);; diff --git a/experimental/garrigue/varunion.ml b/experimental/garrigue/varunion.ml deleted file mode 100644 index 41dca65f..00000000 --- a/experimental/garrigue/varunion.ml +++ /dev/null @@ -1,435 +0,0 @@ -(* 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)) diff --git a/experimental/garrigue/with-module-type.diff b/experimental/garrigue/with-module-type.diff deleted file mode 100644 index 2b99c1f9..00000000 --- a/experimental/garrigue/with-module-type.diff +++ /dev/null @@ -1,530 +0,0 @@ -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 "@[%a@]" self#module_type mt - | _ -> pp f "@[(%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 "@[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; diff --git a/ocamlbuild/test/good-output b/ocamlbuild/test/good-output deleted file mode 100644 index b140dab3..00000000 --- a/ocamlbuild/test/good-output +++ /dev/null @@ -1,1473 +0,0 @@ - _____ _ ____ -|_ _|__ ___| |_|___ \ - | |/ _ \/ __| __| __) | - | | __/\__ \ |_ / __/ - |_|\___||___/\__|_____| - -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 "" OK -Globexp for "" OK -Globexp for " and or " OK -Globexp for " 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" = true OK -Glob.eval "" "helli" = false OK -Glob.eval "" "hello" = true OK -Glob.eval "" "helli" = false OK -Glob.eval "" "hello" = true OK -Glob.eval "" "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 "" "ab" = true OK -Glob.eval "" "acb" = true OK -Glob.eval "" "axxxxxb" = true OK -Glob.eval "" "ababbababb" = true OK -Glob.eval "" "abx" = false OK -Glob.eval "" "xxxxxab" = false OK -Glob.eval "" "xab" = false OK -Glob.eval "" "ab" = true OK -Glob.eval "" "acb" = true OK -Glob.eval "" "axxxxxb" = true OK -Glob.eval "" "ababbababb" = true OK -Glob.eval "" "abx" = false OK -Glob.eval "" "xxxxxab" = false OK -Glob.eval "" "xab" = false OK -Glob.eval "" "ab" = true OK -Glob.eval "" "acb" = true OK -Glob.eval "" "axxxxxb" = true OK -Glob.eval "" "ababbababb" = true OK -Glob.eval "" "abx" = false OK -Glob.eval "" "xxxxxab" = false OK -Glob.eval "" "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" = true OK -Glob.eval "" "" = false OK -Glob.eval "" "aa" = false OK -Glob.eval "" "ba" = false OK -Glob.eval "" "ab" = false OK -Glob.eval "" "abaa" = false OK -Glob.eval "" "a" = true OK -Glob.eval "" "" = false OK -Glob.eval "" "aa" = false OK -Glob.eval "" "ba" = false OK -Glob.eval "" "ab" = false OK -Glob.eval "" "abaa" = false OK -Glob.eval "" "a" = true OK -Glob.eval "" "" = false OK -Glob.eval "" "aa" = false OK -Glob.eval "" "ba" = false OK -Glob.eval "" "ab" = false OK -Glob.eval "" "abaa" = false OK -Glob.eval "" "ab" = true OK -Glob.eval "" "" = false OK -Glob.eval "" "abab" = false OK -Glob.eval "" "aba" = false OK -Glob.eval "" "abx" = false OK -Glob.eval "" "ab" = true OK -Glob.eval "" "" = false OK -Glob.eval "" "abab" = false OK -Glob.eval "" "aba" = false OK -Glob.eval "" "abx" = false OK -Glob.eval "" "ab" = true OK -Glob.eval "" "" = false OK -Glob.eval "" "abab" = false OK -Glob.eval "" "aba" = false OK -Glob.eval "" "abx" = false OK -Glob.eval "" "abac" = true OK -Glob.eval "" "abxc" = true OK -Glob.eval "" "abab" = false OK -Glob.eval "" "ababab" = false OK -Glob.eval "" "ababa" = false OK -Glob.eval "" "abac" = true OK -Glob.eval "" "abxc" = true OK -Glob.eval "" "abab" = false OK -Glob.eval "" "ababab" = false OK -Glob.eval "" "ababa" = false OK -Glob.eval "" "abac" = true OK -Glob.eval "" "abxc" = true OK -Glob.eval "" "abab" = false OK -Glob.eval "" "ababab" = false OK -Glob.eval "" "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 "" "bxx" = true OK -Glob.eval "" "bx" = true OK -Glob.eval "" "aaab" = false OK -Glob.eval "" "" = false OK -Glob.eval "" "bxx" = true OK -Glob.eval "" "bx" = true OK -Glob.eval "" "aaab" = false OK -Glob.eval "" "" = false OK -Glob.eval "" "bxx" = true OK -Glob.eval "" "bx" = true OK -Glob.eval "" "aaab" = false OK -Glob.eval "" "" = 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" = true OK -Glob.eval "" "toto.mli" = true OK -Glob.eval "" "toto." = false OK -Glob.eval "" "toto.mll" = false OK -Glob.eval "" "toto.ml" = true OK -Glob.eval "" "toto.mli" = true OK -Glob.eval "" "toto." = false OK -Glob.eval "" "toto.mll" = false OK -Glob.eval "" "toto.ml" = true OK -Glob.eval "" "toto.mli" = true OK -Glob.eval "" "toto." = false OK -Glob.eval "" "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" = true OK -Glob.eval "" "alpha/gamma/beta" = true OK -Glob.eval "" "alpha/gamma/delta/beta" = true OK -Glob.eval "" "alpha" = false OK -Glob.eval "" "beta" = false OK -Glob.eval "" "gamma/delta" = false OK -Glob.eval "" "alpha/beta" = true OK -Glob.eval "" "alpha/gamma/beta" = true OK -Glob.eval "" "alpha/gamma/delta/beta" = true OK -Glob.eval "" "alpha" = false OK -Glob.eval "" "beta" = false OK -Glob.eval "" "gamma/delta" = false OK -Glob.eval "" "alpha/beta" = true OK -Glob.eval "" "alpha/gamma/beta" = true OK -Glob.eval "" "alpha/gamma/delta/beta" = true OK -Glob.eval "" "alpha" = false OK -Glob.eval "" "beta" = false OK -Glob.eval "" "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/" = true OK -Glob.eval "" "toto/tata" = true OK -Glob.eval "" "toto/alpha/gamma/delta/beta.ml" = true OK -Glob.eval "" "toto" = true OK -Glob.eval "" "toto2/tata" = false OK -Glob.eval "" "tata/titi" = false OK -Glob.eval "" "toto/" = true OK -Glob.eval "" "toto/tata" = true OK -Glob.eval "" "toto/alpha/gamma/delta/beta.ml" = true OK -Glob.eval "" "toto" = true OK -Glob.eval "" "toto2/tata" = false OK -Glob.eval "" "tata/titi" = false OK -Glob.eval "" "toto/" = true OK -Glob.eval "" "toto/tata" = true OK -Glob.eval "" "toto/alpha/gamma/delta/beta.ml" = true OK -Glob.eval "" "toto" = true OK -Glob.eval "" "toto2/tata" = false OK -Glob.eval "" "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 "" OK -Globexp for "" OK -Globexp for " and or " OK -Globexp for " 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" = true OK -Glob.eval "" "helli" = false OK -Glob.eval "" "hello" = true OK -Glob.eval "" "helli" = false OK -Glob.eval "" "hello" = true OK -Glob.eval "" "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 "" "ab" = true OK -Glob.eval "" "acb" = true OK -Glob.eval "" "axxxxxb" = true OK -Glob.eval "" "ababbababb" = true OK -Glob.eval "" "abx" = false OK -Glob.eval "" "xxxxxab" = false OK -Glob.eval "" "xab" = false OK -Glob.eval "" "ab" = true OK -Glob.eval "" "acb" = true OK -Glob.eval "" "axxxxxb" = true OK -Glob.eval "" "ababbababb" = true OK -Glob.eval "" "abx" = false OK -Glob.eval "" "xxxxxab" = false OK -Glob.eval "" "xab" = false OK -Glob.eval "" "ab" = true OK -Glob.eval "" "acb" = true OK -Glob.eval "" "axxxxxb" = true OK -Glob.eval "" "ababbababb" = true OK -Glob.eval "" "abx" = false OK -Glob.eval "" "xxxxxab" = false OK -Glob.eval "" "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" = true OK -Glob.eval "" "" = false OK -Glob.eval "" "aa" = false OK -Glob.eval "" "ba" = false OK -Glob.eval "" "ab" = false OK -Glob.eval "" "abaa" = false OK -Glob.eval "" "a" = true OK -Glob.eval "" "" = false OK -Glob.eval "" "aa" = false OK -Glob.eval "" "ba" = false OK -Glob.eval "" "ab" = false OK -Glob.eval "" "abaa" = false OK -Glob.eval "" "a" = true OK -Glob.eval "" "" = false OK -Glob.eval "" "aa" = false OK -Glob.eval "" "ba" = false OK -Glob.eval "" "ab" = false OK -Glob.eval "" "abaa" = false OK -Glob.eval "" "ab" = true OK -Glob.eval "" "" = false OK -Glob.eval "" "abab" = false OK -Glob.eval "" "aba" = false OK -Glob.eval "" "abx" = false OK -Glob.eval "" "ab" = true OK -Glob.eval "" "" = false OK -Glob.eval "" "abab" = false OK -Glob.eval "" "aba" = false OK -Glob.eval "" "abx" = false OK -Glob.eval "" "ab" = true OK -Glob.eval "" "" = false OK -Glob.eval "" "abab" = false OK -Glob.eval "" "aba" = false OK -Glob.eval "" "abx" = false OK -Glob.eval "" "abac" = true OK -Glob.eval "" "abxc" = true OK -Glob.eval "" "abab" = false OK -Glob.eval "" "ababab" = false OK -Glob.eval "" "ababa" = false OK -Glob.eval "" "abac" = true OK -Glob.eval "" "abxc" = true OK -Glob.eval "" "abab" = false OK -Glob.eval "" "ababab" = false OK -Glob.eval "" "ababa" = false OK -Glob.eval "" "abac" = true OK -Glob.eval "" "abxc" = true OK -Glob.eval "" "abab" = false OK -Glob.eval "" "ababab" = false OK -Glob.eval "" "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 "" "bxx" = true OK -Glob.eval "" "bx" = true OK -Glob.eval "" "aaab" = false OK -Glob.eval "" "" = false OK -Glob.eval "" "bxx" = true OK -Glob.eval "" "bx" = true OK -Glob.eval "" "aaab" = false OK -Glob.eval "" "" = false OK -Glob.eval "" "bxx" = true OK -Glob.eval "" "bx" = true OK -Glob.eval "" "aaab" = false OK -Glob.eval "" "" = 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" = true OK -Glob.eval "" "toto.mli" = true OK -Glob.eval "" "toto." = false OK -Glob.eval "" "toto.mll" = false OK -Glob.eval "" "toto.ml" = true OK -Glob.eval "" "toto.mli" = true OK -Glob.eval "" "toto." = false OK -Glob.eval "" "toto.mll" = false OK -Glob.eval "" "toto.ml" = true OK -Glob.eval "" "toto.mli" = true OK -Glob.eval "" "toto." = false OK -Glob.eval "" "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" = true OK -Glob.eval "" "alpha/gamma/beta" = true OK -Glob.eval "" "alpha/gamma/delta/beta" = true OK -Glob.eval "" "alpha" = false OK -Glob.eval "" "beta" = false OK -Glob.eval "" "gamma/delta" = false OK -Glob.eval "" "alpha/beta" = true OK -Glob.eval "" "alpha/gamma/beta" = true OK -Glob.eval "" "alpha/gamma/delta/beta" = true OK -Glob.eval "" "alpha" = false OK -Glob.eval "" "beta" = false OK -Glob.eval "" "gamma/delta" = false OK -Glob.eval "" "alpha/beta" = true OK -Glob.eval "" "alpha/gamma/beta" = true OK -Glob.eval "" "alpha/gamma/delta/beta" = true OK -Glob.eval "" "alpha" = false OK -Glob.eval "" "beta" = false OK -Glob.eval "" "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/" = true OK -Glob.eval "" "toto/tata" = true OK -Glob.eval "" "toto/alpha/gamma/delta/beta.ml" = true OK -Glob.eval "" "toto" = true OK -Glob.eval "" "toto2/tata" = false OK -Glob.eval "" "tata/titi" = false OK -Glob.eval "" "toto/" = true OK -Glob.eval "" "toto/tata" = true OK -Glob.eval "" "toto/alpha/gamma/delta/beta.ml" = true OK -Glob.eval "" "toto" = true OK -Glob.eval "" "toto2/tata" = false OK -Glob.eval "" "tata/titi" = false OK -Glob.eval "" "toto/" = true OK -Glob.eval "" "toto/tata" = true OK -Glob.eval "" "toto/alpha/gamma/delta/beta.ml" = true OK -Glob.eval "" "toto" = true OK -Glob.eval "" "toto2/tata" = false OK -Glob.eval "" "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 / | | | | |_| |_| | (_| | | - |_|\___||___/\__| \_/ |_|_| \__|\__,_|\__,_|_| - - _____ _ -|_ _|_ _ _ __ __ _ ___| |_ ___ - | |/ _` | '__/ _` |/ _ \ __/ __| - | | (_| | | | (_| | __/ |_\__ \ - |_|\__,_|_| \__, |\___|\__|___/ - |___/ diff --git a/ocamlbuild/test/runtest.sh b/ocamlbuild/test/runtest.sh deleted file mode 100755 index 600f4232..00000000 --- a/ocamlbuild/test/runtest.sh +++ /dev/null @@ -1,56 +0,0 @@ -######################################################################### -# # -# 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 $@ diff --git a/ocamlbuild/test/test1/foo.ml b/ocamlbuild/test/test1/foo.ml deleted file mode 100644 index 304c7649..00000000 --- a/ocamlbuild/test/test1/foo.ml +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test10/dbdi b/ocamlbuild/test/test10/dbdi deleted file mode 100644 index a6b99728..00000000 --- a/ocamlbuild/test/test10/dbdi +++ /dev/null @@ -1,24 +0,0 @@ -(***********************************************************************) -(* *) -(* 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";; diff --git a/ocamlbuild/test/test10/test.sh b/ocamlbuild/test/test10/test.sh deleted file mode 100755 index 2ff23404..00000000 --- a/ocamlbuild/test/test10/test.sh +++ /dev/null @@ -1,18 +0,0 @@ -######################################################################### -# # -# 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 diff --git a/ocamlbuild/test/test11/_tags b/ocamlbuild/test/test11/_tags deleted file mode 100644 index 82387432..00000000 --- a/ocamlbuild/test/test11/_tags +++ /dev/null @@ -1,14 +0,0 @@ -######################################################################### -# # -# 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 diff --git a/ocamlbuild/test/test11/a/aa.ml b/ocamlbuild/test/test11/a/aa.ml deleted file mode 100644 index d373383d..00000000 --- a/ocamlbuild/test/test11/a/aa.ml +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test11/a/aa.mli b/ocamlbuild/test/test11/a/aa.mli deleted file mode 100644 index 45d2d6fd..00000000 --- a/ocamlbuild/test/test11/a/aa.mli +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test11/b/bb.ml b/ocamlbuild/test/test11/b/bb.ml deleted file mode 100644 index f5cce236..00000000 --- a/ocamlbuild/test/test11/b/bb.ml +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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] diff --git a/ocamlbuild/test/test11/b/libb.mllib b/ocamlbuild/test/test11/b/libb.mllib deleted file mode 100644 index d0acbb70..00000000 --- a/ocamlbuild/test/test11/b/libb.mllib +++ /dev/null @@ -1 +0,0 @@ -Bb diff --git a/ocamlbuild/test/test11/myocamlbuild.ml b/ocamlbuild/test/test11/myocamlbuild.ml deleted file mode 100644 index 5a018c20..00000000 --- a/ocamlbuild/test/test11/myocamlbuild.ml +++ /dev/null @@ -1,17 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test11/test.sh b/ocamlbuild/test/test11/test.sh deleted file mode 100755 index 989d051d..00000000 --- a/ocamlbuild/test/test11/test.sh +++ /dev/null @@ -1,25 +0,0 @@ -######################################################################### -# # -# 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 diff --git a/ocamlbuild/test/test2/_tags b/ocamlbuild/test/test2/_tags deleted file mode 100644 index 5db64505..00000000 --- a/ocamlbuild/test/test2/_tags +++ /dev/null @@ -1,15 +0,0 @@ -######################################################################### -# # -# 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 diff --git a/ocamlbuild/test/test2/tata.ml b/ocamlbuild/test/test2/tata.ml deleted file mode 100644 index 2b777f07..00000000 --- a/ocamlbuild/test/test2/tata.ml +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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" diff --git a/ocamlbuild/test/test2/tata.mli b/ocamlbuild/test/test2/tata.mli deleted file mode 100644 index 3fb12338..00000000 --- a/ocamlbuild/test/test2/tata.mli +++ /dev/null @@ -1,14 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test2/test.sh b/ocamlbuild/test/test2/test.sh deleted file mode 100755 index 0843ce42..00000000 --- a/ocamlbuild/test/test2/test.sh +++ /dev/null @@ -1,30 +0,0 @@ -######################################################################### -# # -# 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 diff --git a/ocamlbuild/test/test2/titi.ml b/ocamlbuild/test/test2/titi.ml deleted file mode 100644 index 95dc139c..00000000 --- a/ocamlbuild/test/test2/titi.ml +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 = [] diff --git a/ocamlbuild/test/test2/toto.ml b/ocamlbuild/test/test2/toto.ml deleted file mode 100644 index d0a99c16..00000000 --- a/ocamlbuild/test/test2/toto.ml +++ /dev/null @@ -1,17 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test2/tutu.ml b/ocamlbuild/test/test2/tutu.ml deleted file mode 100644 index e5c5a95a..00000000 --- a/ocamlbuild/test/test2/tutu.ml +++ /dev/null @@ -1,14 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test2/tutu.mli b/ocamlbuild/test/test2/tutu.mli deleted file mode 100644 index bbcd6f88..00000000 --- a/ocamlbuild/test/test2/tutu.mli +++ /dev/null @@ -1,15 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test2/tyty.mli b/ocamlbuild/test/test2/tyty.mli deleted file mode 100644 index cfd91160..00000000 --- a/ocamlbuild/test/test2/tyty.mli +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test2/vivi1.ml b/ocamlbuild/test/test2/vivi1.ml deleted file mode 100644 index 78aaf09d..00000000 --- a/ocamlbuild/test/test2/vivi1.ml +++ /dev/null @@ -1,14 +0,0 @@ -(***********************************************************************) -(* *) -(* 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|] diff --git a/ocamlbuild/test/test2/vivi2.ml b/ocamlbuild/test/test2/vivi2.ml deleted file mode 100644 index dd14288f..00000000 --- a/ocamlbuild/test/test2/vivi2.ml +++ /dev/null @@ -1,14 +0,0 @@ -(***********************************************************************) -(* *) -(* 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|] diff --git a/ocamlbuild/test/test2/vivi3.ml b/ocamlbuild/test/test2/vivi3.ml deleted file mode 100644 index 89c4bc33..00000000 --- a/ocamlbuild/test/test2/vivi3.ml +++ /dev/null @@ -1,14 +0,0 @@ -(***********************************************************************) -(* *) -(* 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|] diff --git a/ocamlbuild/test/test3/_tags b/ocamlbuild/test/test3/_tags deleted file mode 100644 index b2018471..00000000 --- a/ocamlbuild/test/test3/_tags +++ /dev/null @@ -1,13 +0,0 @@ -######################################################################### -# # -# 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 diff --git a/ocamlbuild/test/test3/a.ml b/ocamlbuild/test/test3/a.ml deleted file mode 100644 index 8943491c..00000000 --- a/ocamlbuild/test/test3/a.ml +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test3/a.mli b/ocamlbuild/test/test3/a.mli deleted file mode 100644 index 2978f3bc..00000000 --- a/ocamlbuild/test/test3/a.mli +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 *) diff --git a/ocamlbuild/test/test3/b.ml b/ocamlbuild/test/test3/b.ml deleted file mode 100644 index 2074ea5c..00000000 --- a/ocamlbuild/test/test3/b.ml +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test3/b.mli b/ocamlbuild/test/test3/b.mli deleted file mode 100644 index 289f91f3..00000000 --- a/ocamlbuild/test/test3/b.mli +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 *) diff --git a/ocamlbuild/test/test3/c.ml b/ocamlbuild/test/test3/c.ml deleted file mode 100644 index 5a161603..00000000 --- a/ocamlbuild/test/test3/c.ml +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test3/c.mli b/ocamlbuild/test/test3/c.mli deleted file mode 100644 index 289f91f3..00000000 --- a/ocamlbuild/test/test3/c.mli +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 *) diff --git a/ocamlbuild/test/test3/d.ml b/ocamlbuild/test/test3/d.ml deleted file mode 100644 index 8b96630e..00000000 --- a/ocamlbuild/test/test3/d.ml +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test3/d.mli b/ocamlbuild/test/test3/d.mli deleted file mode 100644 index 289f91f3..00000000 --- a/ocamlbuild/test/test3/d.mli +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 *) diff --git a/ocamlbuild/test/test3/e.ml b/ocamlbuild/test/test3/e.ml deleted file mode 100644 index 3ac83e48..00000000 --- a/ocamlbuild/test/test3/e.ml +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test3/e.mli b/ocamlbuild/test/test3/e.mli deleted file mode 100644 index 289f91f3..00000000 --- a/ocamlbuild/test/test3/e.mli +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 *) diff --git a/ocamlbuild/test/test3/f.ml b/ocamlbuild/test/test3/f.ml deleted file mode 100644 index 7c1ae8d4..00000000 --- a/ocamlbuild/test/test3/f.ml +++ /dev/null @@ -1,14 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test3/f.mli b/ocamlbuild/test/test3/f.mli deleted file mode 100644 index 289f91f3..00000000 --- a/ocamlbuild/test/test3/f.mli +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 *) diff --git a/ocamlbuild/test/test3/proj.odocl b/ocamlbuild/test/test3/proj.odocl deleted file mode 100644 index 532c7203..00000000 --- a/ocamlbuild/test/test3/proj.odocl +++ /dev/null @@ -1 +0,0 @@ -A B C D E F diff --git a/ocamlbuild/test/test3/test.sh b/ocamlbuild/test/test3/test.sh deleted file mode 100755 index d3b28526..00000000 --- a/ocamlbuild/test/test3/test.sh +++ /dev/null @@ -1,23 +0,0 @@ -######################################################################### -# # -# 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 diff --git a/ocamlbuild/test/test4/_tags b/ocamlbuild/test/test4/_tags deleted file mode 100644 index f381c675..00000000 --- a/ocamlbuild/test/test4/_tags +++ /dev/null @@ -1,14 +0,0 @@ -######################################################################### -# # -# 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 diff --git a/ocamlbuild/test/test4/a/aa.ml b/ocamlbuild/test/test4/a/aa.ml deleted file mode 100644 index d373383d..00000000 --- a/ocamlbuild/test/test4/a/aa.ml +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test4/a/aa.mli b/ocamlbuild/test/test4/a/aa.mli deleted file mode 100644 index 45d2d6fd..00000000 --- a/ocamlbuild/test/test4/a/aa.mli +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test4/b/bb.ml b/ocamlbuild/test/test4/b/bb.ml deleted file mode 100644 index 65777877..00000000 --- a/ocamlbuild/test/test4/b/bb.ml +++ /dev/null @@ -1,14 +0,0 @@ -(***********************************************************************) -(* *) -(* 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] diff --git a/ocamlbuild/test/test4/test.sh b/ocamlbuild/test/test4/test.sh deleted file mode 100755 index 46b7129d..00000000 --- a/ocamlbuild/test/test4/test.sh +++ /dev/null @@ -1,23 +0,0 @@ -######################################################################### -# # -# 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 diff --git a/ocamlbuild/test/test5/_tags b/ocamlbuild/test/test5/_tags deleted file mode 100644 index daa80725..00000000 --- a/ocamlbuild/test/test5/_tags +++ /dev/null @@ -1,13 +0,0 @@ -######################################################################### -# # -# 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) diff --git a/ocamlbuild/test/test5/a.ml b/ocamlbuild/test/test5/a.ml deleted file mode 100644 index 89039068..00000000 --- a/ocamlbuild/test/test5/a.ml +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test5/a.mli b/ocamlbuild/test/test5/a.mli deleted file mode 100644 index c263e150..00000000 --- a/ocamlbuild/test/test5/a.mli +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test5/b.ml b/ocamlbuild/test/test5/b.ml deleted file mode 100644 index 72ec04e9..00000000 --- a/ocamlbuild/test/test5/b.ml +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test5/c.mlpack b/ocamlbuild/test/test5/c.mlpack deleted file mode 100644 index 5decc2b6..00000000 --- a/ocamlbuild/test/test5/c.mlpack +++ /dev/null @@ -1 +0,0 @@ -A B diff --git a/ocamlbuild/test/test5/d.ml b/ocamlbuild/test/test5/d.ml deleted file mode 100644 index 171ecf5a..00000000 --- a/ocamlbuild/test/test5/d.ml +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test5/stack.ml b/ocamlbuild/test/test5/stack.ml deleted file mode 100644 index 0acc39d3..00000000 --- a/ocamlbuild/test/test5/stack.ml +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test5/test.sh b/ocamlbuild/test/test5/test.sh deleted file mode 100755 index 30bba5ce..00000000 --- a/ocamlbuild/test/test5/test.sh +++ /dev/null @@ -1,23 +0,0 @@ -######################################################################### -# # -# 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 diff --git a/ocamlbuild/test/test6/a.ml b/ocamlbuild/test/test6/a.ml deleted file mode 100644 index 045a8047..00000000 --- a/ocamlbuild/test/test6/a.ml +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test6/a.mli b/ocamlbuild/test/test6/a.mli deleted file mode 100644 index a8f98ba8..00000000 --- a/ocamlbuild/test/test6/a.mli +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test6/b.ml b/ocamlbuild/test/test6/b.ml deleted file mode 100644 index de477cef..00000000 --- a/ocamlbuild/test/test6/b.ml +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test6/b.mli b/ocamlbuild/test/test6/b.mli deleted file mode 100644 index 5f545ae6..00000000 --- a/ocamlbuild/test/test6/b.mli +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test6/b.mli.v1 b/ocamlbuild/test/test6/b.mli.v1 deleted file mode 100644 index 5f545ae6..00000000 --- a/ocamlbuild/test/test6/b.mli.v1 +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test6/b.mli.v2 b/ocamlbuild/test/test6/b.mli.v2 deleted file mode 100644 index ede11d29..00000000 --- a/ocamlbuild/test/test6/b.mli.v2 +++ /dev/null @@ -1,14 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test6/d.ml b/ocamlbuild/test/test6/d.ml deleted file mode 100644 index db9a453c..00000000 --- a/ocamlbuild/test/test6/d.ml +++ /dev/null @@ -1,14 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test6/d.mli b/ocamlbuild/test/test6/d.mli deleted file mode 100644 index 496f5992..00000000 --- a/ocamlbuild/test/test6/d.mli +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test6/d.mli.v1 b/ocamlbuild/test/test6/d.mli.v1 deleted file mode 100644 index 26b952ce..00000000 --- a/ocamlbuild/test/test6/d.mli.v1 +++ /dev/null @@ -1,14 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test6/d.mli.v2 b/ocamlbuild/test/test6/d.mli.v2 deleted file mode 100644 index 496f5992..00000000 --- a/ocamlbuild/test/test6/d.mli.v2 +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test6/main.ml b/ocamlbuild/test/test6/main.ml deleted file mode 100644 index 6d20a21d..00000000 --- a/ocamlbuild/test/test6/main.ml +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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. diff --git a/ocamlbuild/test/test6/main.mli b/ocamlbuild/test/test6/main.mli deleted file mode 100644 index 289f91f3..00000000 --- a/ocamlbuild/test/test6/main.mli +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 *) diff --git a/ocamlbuild/test/test6/test.sh b/ocamlbuild/test/test6/test.sh deleted file mode 100755 index 8fb2e67e..00000000 --- a/ocamlbuild/test/test6/test.sh +++ /dev/null @@ -1,37 +0,0 @@ -######################################################################### -# # -# 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 diff --git a/ocamlbuild/test/test7/_tags b/ocamlbuild/test/test7/_tags deleted file mode 100644 index ec07803c..00000000 --- a/ocamlbuild/test/test7/_tags +++ /dev/null @@ -1,13 +0,0 @@ -######################################################################### -# # -# 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 diff --git a/ocamlbuild/test/test7/aa.ml b/ocamlbuild/test/test7/aa.ml deleted file mode 100644 index c4521f0d..00000000 --- a/ocamlbuild/test/test7/aa.ml +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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" diff --git a/ocamlbuild/test/test7/bb.mli b/ocamlbuild/test/test7/bb.mli deleted file mode 100644 index 63af4358..00000000 --- a/ocamlbuild/test/test7/bb.mli +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test7/bb1.ml b/ocamlbuild/test/test7/bb1.ml deleted file mode 100644 index 0b18853a..00000000 --- a/ocamlbuild/test/test7/bb1.ml +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test7/bb2.ml b/ocamlbuild/test/test7/bb2.ml deleted file mode 100644 index 25221836..00000000 --- a/ocamlbuild/test/test7/bb2.ml +++ /dev/null @@ -1,15 +0,0 @@ -(***********************************************************************) -(* *) -(* 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) diff --git a/ocamlbuild/test/test7/bb3.ml b/ocamlbuild/test/test7/bb3.ml deleted file mode 100644 index 11e3b9e1..00000000 --- a/ocamlbuild/test/test7/bb3.ml +++ /dev/null @@ -1,15 +0,0 @@ -(***********************************************************************) -(* *) -(* 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) diff --git a/ocamlbuild/test/test7/bbcc.mllib b/ocamlbuild/test/test7/bbcc.mllib deleted file mode 100644 index a97a0e6c..00000000 --- a/ocamlbuild/test/test7/bbcc.mllib +++ /dev/null @@ -1 +0,0 @@ -Bb Cc diff --git a/ocamlbuild/test/test7/c2.ml b/ocamlbuild/test/test7/c2.ml deleted file mode 100644 index d15ee418..00000000 --- a/ocamlbuild/test/test7/c2.ml +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test7/c2.mli b/ocamlbuild/test/test7/c2.mli deleted file mode 100644 index 9ec012b2..00000000 --- a/ocamlbuild/test/test7/c2.mli +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test7/c3.ml b/ocamlbuild/test/test7/c3.ml deleted file mode 100644 index 1596a100..00000000 --- a/ocamlbuild/test/test7/c3.ml +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test7/cc.ml b/ocamlbuild/test/test7/cc.ml deleted file mode 100644 index 1cba0473..00000000 --- a/ocamlbuild/test/test7/cc.ml +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test7/cool_plugin.ml b/ocamlbuild/test/test7/cool_plugin.ml deleted file mode 100644 index b5400a54..00000000 --- a/ocamlbuild/test/test7/cool_plugin.ml +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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" diff --git a/ocamlbuild/test/test7/main.ml b/ocamlbuild/test/test7/main.ml deleted file mode 100644 index 817ef569..00000000 --- a/ocamlbuild/test/test7/main.ml +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test7/myocamlbuild.ml b/ocamlbuild/test/test7/myocamlbuild.ml deleted file mode 100644 index 1d33e0bf..00000000 --- a/ocamlbuild/test/test7/myocamlbuild.ml +++ /dev/null @@ -1,19 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test7/test.sh b/ocamlbuild/test/test7/test.sh deleted file mode 100755 index 1d4eb1b5..00000000 --- a/ocamlbuild/test/test7/test.sh +++ /dev/null @@ -1,30 +0,0 @@ -######################################################################### -# # -# 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 diff --git a/ocamlbuild/test/test8/a.ml b/ocamlbuild/test/test8/a.ml deleted file mode 100644 index c333d438..00000000 --- a/ocamlbuild/test/test8/a.ml +++ /dev/null @@ -1,13 +0,0 @@ -(***********************************************************************) -(* *) -(* 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;; diff --git a/ocamlbuild/test/test8/myocamlbuild.ml b/ocamlbuild/test/test8/myocamlbuild.ml deleted file mode 100644 index 52330ec6..00000000 --- a/ocamlbuild/test/test8/myocamlbuild.ml +++ /dev/null @@ -1,28 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test8/test.sh b/ocamlbuild/test/test8/test.sh deleted file mode 100755 index 9b57933c..00000000 --- a/ocamlbuild/test/test8/test.sh +++ /dev/null @@ -1,23 +0,0 @@ -######################################################################### -# # -# 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 diff --git a/ocamlbuild/test/test9/dbgl b/ocamlbuild/test/test9/dbgl deleted file mode 100644 index 78290948..00000000 --- a/ocamlbuild/test/test9/dbgl +++ /dev/null @@ -1,22 +0,0 @@ -(***********************************************************************) -(* *) -(* 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;; diff --git a/ocamlbuild/test/test9/test.sh b/ocamlbuild/test/test9/test.sh deleted file mode 100755 index aaed954c..00000000 --- a/ocamlbuild/test/test9/test.sh +++ /dev/null @@ -1,18 +0,0 @@ -######################################################################### -# # -# 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 diff --git a/ocamlbuild/test/test9/testglob.ml b/ocamlbuild/test/test9/testglob.ml deleted file mode 100644 index 77778731..00000000 --- a/ocamlbuild/test/test9/testglob.ml +++ /dev/null @@ -1,146 +0,0 @@ -(***********************************************************************) -(* *) -(* 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; - "", true; - "", true; - " and or ", true; - " 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"], ["helli"]; - "\"hello\"", ["hello"], ["heidi"]; - "<*>", ["";"a";"ax"], []; - "", ["ab";"acb";"axxxxxb";"ababbababb"], ["abx";"xxxxxab";"xab"]; - "<*.ml>", ["hello.ml";".ml"], ["ml"; ""; "toto.mli"]; - "", ["a"], ["";"aa";"ba";"ab";"abaa"]; - "", ["ab"], ["";"abab";"aba";"abx"]; - "", ["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"]; - "", ["bxx";"bx"], ["aaab";""]; - "<*>", ["";"a";"aaa";"aaaaa"], []; - "", ["a"],["";"aaa";"aaaaa"]; - "<{a,b}>", ["a";"b"],["";"aa";"ab";"ba";"bb";"c"]; - "", ["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/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/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 -;; diff --git a/ocamlbuild/test/test_virtual/foo.itarget b/ocamlbuild/test/test_virtual/foo.itarget deleted file mode 100644 index 257cc564..00000000 --- a/ocamlbuild/test/test_virtual/foo.itarget +++ /dev/null @@ -1 +0,0 @@ -foo diff --git a/ocamlbuild/test/test_virtual/foo1 b/ocamlbuild/test/test_virtual/foo1 deleted file mode 100644 index 1715acd6..00000000 --- a/ocamlbuild/test/test_virtual/foo1 +++ /dev/null @@ -1 +0,0 @@ -foo1 diff --git a/ocamlbuild/test/test_virtual/foo2 b/ocamlbuild/test/test_virtual/foo2 deleted file mode 100644 index 54b060ee..00000000 --- a/ocamlbuild/test/test_virtual/foo2 +++ /dev/null @@ -1 +0,0 @@ -foo2 diff --git a/ocamlbuild/test/test_virtual/myocamlbuild.ml b/ocamlbuild/test/test_virtual/myocamlbuild.ml deleted file mode 100644 index 049628fa..00000000 --- a/ocamlbuild/test/test_virtual/myocamlbuild.ml +++ /dev/null @@ -1,23 +0,0 @@ -(***********************************************************************) -(* *) -(* 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 diff --git a/ocamlbuild/test/test_virtual/test.sh b/ocamlbuild/test/test_virtual/test.sh deleted file mode 100755 index 9960c83f..00000000 --- a/ocamlbuild/test/test_virtual/test.sh +++ /dev/null @@ -1,28 +0,0 @@ -######################################################################### -# # -# 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 -- 2.30.2