This patch (against OCaml 3.07) fixes the following issues: - Camlp4: parsing of labeled function arguments. - Emacs interface: portability issues between versions of GnuEmacs and XEmacs. - Incorrect code generated for certain recursive module definitions. - Name pollution issue on Mac OS X 10.3. How to apply this patch: * Go to the ocaml-3.07 source directory. * Do "make clean". * If you already applied the earlier patch ocaml-3.07-patch1.diffs, un-apply it first by running patch -p1 -R < /path/to/ocaml-3.07-patch1.diffs * Run patch -p1 < /path/to/ocaml-3.07-patch2.diffs (this patch) * Compile and install as usual (see file INSTALL). -------------- Index: csl/bytecomp/translmod.ml diff -u csl/bytecomp/translmod.ml:1.44 csl/bytecomp/translmod.ml:1.45 --- csl/bytecomp/translmod.ml:1.44 Mon Jul 7 15:42:49 2003 +++ csl/bytecomp/translmod.ml Fri Oct 3 16:36:00 2003 @@ -310,11 +310,12 @@ transl_module Tcoerce_none (field_path rootpath id) modl, transl_structure (id :: fields) cc rootpath rem) | Tstr_recmodule bindings :: rem -> + let ext_fields = List.rev_append (List.map fst bindings) fields in compile_recmodule (fun id modl -> transl_module Tcoerce_none (field_path rootpath id) modl) bindings - (transl_structure (map_end fst bindings fields) cc rootpath rem) + (transl_structure ext_fields cc rootpath rem) | Tstr_modtype(id, decl) :: rem -> transl_structure fields cc rootpath rem | Tstr_open path :: rem -> Index: csl/camlp4/camlp4/ast2pt.ml diff -u csl/camlp4/camlp4/ast2pt.ml:1.25 csl/camlp4/camlp4/ast2pt.ml:1.26 --- csl/camlp4/camlp4/ast2pt.ml:1.25 Wed Jul 16 20:59:12 2003 +++ csl/camlp4/camlp4/ast2pt.ml Tue Sep 30 16:39:26 2003 @@ -177,10 +177,10 @@ | TyObj loc fl v -> mktyp loc (Ptyp_object (meth_list loc fl v)) | TyCls loc id -> mktyp loc (Ptyp_class (long_id_of_string_list loc id) [] []) - | TyLab loc _ _ -> error loc "labeled type not allowed here" + | TyLab loc _ _ -> error loc "labelled type not allowed here" | TyLid loc s -> mktyp loc (Ptyp_constr (lident s) []) - | TyMan loc _ _ -> error loc "type manifest not allowed here" - | TyOlb loc lab _ -> error loc "labeled type not allowed here" + | TyMan loc _ _ -> error loc "manifest type not allowed here" + | TyOlb loc lab _ -> error loc "labelled type not allowed here" | TyPol loc pl t -> mktyp loc (Ptyp_poly pl (ctyp t)) | TyQuo loc s -> mktyp loc (Ptyp_var s) | TyRec loc _ _ -> error loc "record type not allowed here" Index: csl/camlp4/etc/pa_o.ml diff -u csl/camlp4/etc/pa_o.ml:1.52 csl/camlp4/etc/pa_o.ml:1.54 --- csl/camlp4/etc/pa_o.ml:1.52 Thu Sep 25 14:05:05 2003 +++ csl/camlp4/etc/pa_o.ml Tue Sep 30 16:39:38 2003 @@ -1148,16 +1148,16 @@ | i = LIDENT -> [i] ] ] ; (* Labels *) - ctyp: AFTER "arrow" - [ NONA + ctyp: LEVEL "arrow" + [ RIGHTA [ i = lident_colon; t1 = ctyp LEVEL "star"; "->"; t2 = SELF -> - <:ctyp< ~ $i$ : $t1$ -> $t2$ >> + <:ctyp< ( ~ $i$ : $t1$ ) -> $t2$ >> | i = OPTLABEL; t1 = ctyp LEVEL "star"; "->"; t2 = SELF -> - <:ctyp< ? $i$ : $t1$ -> $t2$ >> + <:ctyp< ( ? $i$ : $t1$ ) -> $t2$ >> | i = QUESTIONIDENT; ":"; t1 = ctyp LEVEL "star"; "->"; t2 = SELF -> - <:ctyp< ? $i$ : $t1$ -> $t2$ >> + <:ctyp< ( ? $i$ : $t1$ ) -> $t2$ >> | "?"; i=lident_colon;t1 = ctyp LEVEL "star"; "->"; t2 = SELF -> - <:ctyp< ? $i$ : $t1$ -> $t2$ >> ] ] + <:ctyp< ( ? $i$ : $t1$ ) -> $t2$ >> ] ] ; ctyp: LEVEL "simple" [ [ "["; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" -> Index: csl/camlp4/meta/pa_r.ml diff -u csl/camlp4/meta/pa_r.ml:1.53 csl/camlp4/meta/pa_r.ml:1.55 --- csl/camlp4/meta/pa_r.ml:1.53 Thu Sep 25 14:05:06 2003 +++ csl/camlp4/meta/pa_r.ml Thu Oct 2 14:33:43 2003 @@ -542,6 +542,11 @@ <:ctyp< ! $list:pl$ . $t$ >> ] | "arrow" RIGHTA [ t1 = SELF; "->"; t2 = SELF -> <:ctyp< $t1$ -> $t2$ >> ] + | "label" NONA + [ i = TILDEIDENT; ":"; t = SELF -> <:ctyp< ~ $i$ : $t$ >> + | i = LABEL; t = SELF -> <:ctyp< ~ $i$ : $t$ >> + | i = QUESTIONIDENT; ":"; t = SELF -> <:ctyp< ? $i$ : $t$ >> + | i = OPTLABEL; t = SELF -> <:ctyp< ? $i$ : $t$ >> ] | LEFTA [ t1 = SELF; t2 = SELF -> <:ctyp< $t1$ $t2$ >> ] | LEFTA @@ -746,14 +751,6 @@ class_longident: [ [ m = UIDENT; "."; l = SELF -> [m :: l] | i = LIDENT -> [i] ] ] - ; - (* Labels *) - ctyp: AFTER "arrow" - [ NONA - [ i = TILDEIDENT; ":"; t = SELF -> <:ctyp< ~ $i$ : $t$ >> - | i = LABEL; t = SELF -> <:ctyp< ~ $i$ : $t$ >> - | i = QUESTIONIDENT; ":"; t = SELF -> <:ctyp< ? $i$ : $t$ >> - | i = OPTLABEL; t = SELF -> <:ctyp< ? $i$ : $t$ >> ] ] ; ctyp: LEVEL "simple" [ [ "["; "="; rfl = row_field_list; "]" -> Index: csl/camlp4/meta/q_MLast.ml diff -u csl/camlp4/meta/q_MLast.ml:1.51 csl/camlp4/meta/q_MLast.ml:1.53 --- csl/camlp4/meta/q_MLast.ml:1.51 Wed Jul 16 14:50:08 2003 +++ csl/camlp4/meta/q_MLast.ml Thu Oct 2 14:33:43 2003 @@ -127,7 +127,9 @@ value a_STRING = Grammar.Entry.create gram "a_STRING"; value a_CHAR = Grammar.Entry.create gram "a_CHAR"; value a_TILDEIDENT = Grammar.Entry.create gram "a_TILDEIDENT"; +value a_LABEL = Grammar.Entry.create gram "a_LABEL"; value a_QUESTIONIDENT = Grammar.Entry.create gram "a_QUESTIONIDENT"; +value a_OPTLABEL = Grammar.Entry.create gram "a_OPTLABEL"; value o2b = fun @@ -793,6 +795,13 @@ Qast.Node "TyPol" [Qast.Loc; pl; t] ] | "arrow" RIGHTA [ t1 = SELF; "->"; t2 = SELF -> Qast.Node "TyArr" [Qast.Loc; t1; t2] ] + | "label" NONA + [ i = a_TILDEIDENT; ":"; t = SELF -> Qast.Node "TyLab" [Qast.Loc; i; t] + | i = a_LABEL; t = SELF -> Qast.Node "TyLab" [Qast.Loc; i; t] + | i = a_QUESTIONIDENT; ":"; t = SELF -> + Qast.Node "TyOlb" [Qast.Loc; i; t] + | i = a_OPTLABEL; t = SELF -> + Qast.Node "TyOlb" [Qast.Loc; i; t] ] | LEFTA [ t1 = SELF; t2 = SELF -> Qast.Node "TyApp" [Qast.Loc; t1; t2] ] | LEFTA @@ -1006,13 +1015,6 @@ [ [ m = a_UIDENT; "."; l = SELF -> Qast.Cons m l | i = a_LIDENT -> Qast.List [i] ] ] ; - (* Labels *) - ctyp: AFTER "arrow" - [ NONA - [ i = a_TILDEIDENT; ":"; t = SELF -> Qast.Node "TyLab" [Qast.Loc; i; t] - | i = a_QUESTIONIDENT; ":"; t = SELF -> - Qast.Node "TyOlb" [Qast.Loc; i; t] ] ] - ; ctyp: LEVEL "simple" [ [ "["; "="; rfl = row_field_list; "]" -> Qast.Node "TyVrn" [Qast.Loc; rfl; Qast.Option None] @@ -1044,11 +1046,16 @@ | "#"; sl = mod_ident -> Qast.Node "PaTyp" [Qast.Loc; sl] | i = a_TILDEIDENT; ":"; p = SELF -> Qast.Node "PaLab" [Qast.Loc; i; Qast.Option (Some p)] + | i = a_LABEL; p = SELF -> + Qast.Node "PaLab" [Qast.Loc; i; Qast.Option (Some p)] | i = a_TILDEIDENT -> Qast.Node "PaLab" [Qast.Loc; i; Qast.Option None] | i = a_QUESTIONIDENT; ":"; "("; p = patt_tcon; eo = SOPT eq_expr; ")" -> Qast.Node "PaOlb" [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))] + | i = a_OPTLABEL; "("; p = patt_tcon; eo = SOPT eq_expr; ")" -> + Qast.Node "PaOlb" + [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))] | i = a_QUESTIONIDENT -> Qast.Node "PaOlb" [Qast.Loc; i; Qast.Option None] | "?"; "("; p = patt_tcon; eo = SOPT eq_expr; ")" -> @@ -1063,11 +1070,16 @@ ipatt: [ [ i = a_TILDEIDENT; ":"; p = SELF -> Qast.Node "PaLab" [Qast.Loc; i; Qast.Option (Some p)] + | i = a_LABEL; p = SELF -> + Qast.Node "PaLab" [Qast.Loc; i; Qast.Option (Some p)] | i = a_TILDEIDENT -> Qast.Node "PaLab" [Qast.Loc; i; Qast.Option None] | i = a_QUESTIONIDENT; ":"; "("; p = ipatt_tcon; eo = SOPT eq_expr; ")" -> Qast.Node "PaOlb" [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))] + | i = a_OPTLABEL; "("; p = ipatt_tcon; eo = SOPT eq_expr; ")" -> + Qast.Node "PaOlb" + [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))] | i = a_QUESTIONIDENT -> Qast.Node "PaOlb" [Qast.Loc; i; Qast.Option None] | "?"; "("; p = ipatt_tcon; eo = SOPT eq_expr; ")" -> @@ -1086,9 +1098,13 @@ [ "label" NONA [ i = a_TILDEIDENT; ":"; e = SELF -> Qast.Node "ExLab" [Qast.Loc; i; Qast.Option (Some e)] + | i = a_LABEL; e = SELF -> + Qast.Node "ExLab" [Qast.Loc; i; Qast.Option (Some e)] | i = a_TILDEIDENT -> Qast.Node "ExLab" [Qast.Loc; i; Qast.Option None] | i = a_QUESTIONIDENT; ":"; e = SELF -> Qast.Node "ExOlb" [Qast.Loc; i; Qast.Option (Some e)] + | i = a_OPTLABEL; e = SELF -> + Qast.Node "ExOlb" [Qast.Loc; i; Qast.Option (Some e)] | i = a_QUESTIONIDENT -> Qast.Node "ExOlb" [Qast.Loc; i; Qast.Option None] ] ] ; @@ -1335,9 +1351,15 @@ [ [ "~"; a = ANTIQUOT -> antiquot "" loc a | s = TILDEIDENT -> Qast.Str s ] ] ; + a_LABEL: + [ [ s = LABEL -> Qast.Str s ] ] + ; a_QUESTIONIDENT: [ [ "?"; a = ANTIQUOT -> antiquot "" loc a | s = QUESTIONIDENT -> Qast.Str s ] ] + ; + a_OPTLABEL: + [ [ s = OPTLABEL -> Qast.Str s ] ] ; END; Index: csl/camlp4/ocaml_src/camlp4/ast2pt.ml diff -u csl/camlp4/ocaml_src/camlp4/ast2pt.ml:1.24 csl/camlp4/ocaml_src/camlp4/ast2pt.ml:1.25 --- csl/camlp4/ocaml_src/camlp4/ast2pt.ml:1.24 Thu Jul 24 00:26:18 2003 +++ csl/camlp4/ocaml_src/camlp4/ast2pt.ml Tue Sep 30 16:39:38 2003 @@ -169,10 +169,10 @@ | TyObj (loc, fl, v) -> mktyp loc (Ptyp_object (meth_list loc fl v)) | TyCls (loc, id) -> mktyp loc (Ptyp_class (long_id_of_string_list loc id, [], [])) - | TyLab (loc, _, _) -> error loc "labeled type not allowed here" + | TyLab (loc, _, _) -> error loc "labelled type not allowed here" | TyLid (loc, s) -> mktyp loc (Ptyp_constr (lident s, [])) - | TyMan (loc, _, _) -> error loc "type manifest not allowed here" - | TyOlb (loc, lab, _) -> error loc "labeled type not allowed here" + | TyMan (loc, _, _) -> error loc "manifest type not allowed here" + | TyOlb (loc, lab, _) -> error loc "labelled type not allowed here" | TyPol (loc, pl, t) -> mktyp loc (Ptyp_poly (pl, ctyp t)) | TyQuo (loc, s) -> mktyp loc (Ptyp_var s) | TyRec (loc, _, _) -> error loc "record type not allowed here" Index: csl/camlp4/ocaml_src/meta/pa_r.ml diff -u csl/camlp4/ocaml_src/meta/pa_r.ml:1.48 csl/camlp4/ocaml_src/meta/pa_r.ml:1.50 --- csl/camlp4/ocaml_src/meta/pa_r.ml:1.48 Thu Sep 25 14:05:07 2003 +++ csl/camlp4/ocaml_src/meta/pa_r.ml Thu Oct 2 14:33:44 2003 @@ -1540,6 +1540,25 @@ Gramext.action (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (loc : int * int) -> (MLast.TyArr (loc, t1, t2) : 'ctyp))]; + Some "label", Some Gramext.NonA, + [[Gramext.Stoken ("OPTLABEL", ""); Gramext.Sself], + Gramext.action + (fun (t : 'ctyp) (i : string) (loc : int * int) -> + (MLast.TyOlb (loc, i, t) : 'ctyp)); + [Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":"); + Gramext.Sself], + Gramext.action + (fun (t : 'ctyp) _ (i : string) (loc : int * int) -> + (MLast.TyOlb (loc, i, t) : 'ctyp)); + [Gramext.Stoken ("LABEL", ""); Gramext.Sself], + Gramext.action + (fun (t : 'ctyp) (i : string) (loc : int * int) -> + (MLast.TyLab (loc, i, t) : 'ctyp)); + [Gramext.Stoken ("TILDEIDENT", ""); Gramext.Stoken ("", ":"); + Gramext.Sself], + Gramext.action + (fun (t : 'ctyp) _ (i : string) (loc : int * int) -> + (MLast.TyLab (loc, i, t) : 'ctyp))]; None, Some Gramext.LeftA, [[Gramext.Sself; Gramext.Sself], Gramext.action @@ -2240,27 +2259,6 @@ Gramext.action (fun (l : 'class_longident) _ (m : string) (loc : int * int) -> (m :: l : 'class_longident))]]; - Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), - Some (Gramext.After "arrow"), - [None, Some Gramext.NonA, - [[Gramext.Stoken ("OPTLABEL", ""); Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) (i : string) (loc : int * int) -> - (MLast.TyOlb (loc, i, t) : 'ctyp)); - [Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) _ (i : string) (loc : int * int) -> - (MLast.TyOlb (loc, i, t) : 'ctyp)); - [Gramext.Stoken ("LABEL", ""); Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) (i : string) (loc : int * int) -> - (MLast.TyLab (loc, i, t) : 'ctyp)); - [Gramext.Stoken ("TILDEIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) _ (i : string) (loc : int * int) -> - (MLast.TyLab (loc, i, t) : 'ctyp))]]; Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), Some (Gramext.Level "simple"), [None, None, Index: csl/camlp4/ocaml_src/meta/q_MLast.ml diff -u csl/camlp4/ocaml_src/meta/q_MLast.ml:1.56 csl/camlp4/ocaml_src/meta/q_MLast.ml:1.58 --- csl/camlp4/ocaml_src/meta/q_MLast.ml:1.56 Thu Jul 24 00:26:19 2003 +++ csl/camlp4/ocaml_src/meta/q_MLast.ml Thu Oct 2 14:33:44 2003 @@ -153,7 +153,9 @@ let a_STRING = Grammar.Entry.create gram "a_STRING";; let a_CHAR = Grammar.Entry.create gram "a_CHAR";; let a_TILDEIDENT = Grammar.Entry.create gram "a_TILDEIDENT";; +let a_LABEL = Grammar.Entry.create gram "a_LABEL";; let a_QUESTIONIDENT = Grammar.Entry.create gram "a_QUESTIONIDENT";; +let a_OPTLABEL = Grammar.Entry.create gram "a_OPTLABEL";; let o2b = function @@ -626,7 +628,7 @@ Qast.Tuple [xx1; xx2; xx3] -> xx1, xx2, xx3 | _ -> match () with - _ -> raise (Match_failure ("q_MLast.ml", 300, 19)) + _ -> raise (Match_failure ("q_MLast.ml", 302, 19)) in Qast.Node ("StExc", [Qast.Loc; c; tl; b]) : 'str_item)); @@ -896,7 +898,7 @@ Qast.Tuple [xx1; xx2; xx3] -> xx1, xx2, xx3 | _ -> match () with - _ -> raise (Match_failure ("q_MLast.ml", 358, 19)) + _ -> raise (Match_failure ("q_MLast.ml", 360, 19)) in Qast.Node ("SgExc", [Qast.Loc; c; tl]) : 'sig_item)); @@ -2254,6 +2256,32 @@ Gramext.action (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (loc : int * int) -> (Qast.Node ("TyArr", [Qast.Loc; t1; t2]) : 'ctyp))]; + Some "label", Some Gramext.NonA, + [[Gramext.Snterm + (Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e)); + Gramext.Sself], + Gramext.action + (fun (t : 'ctyp) (i : 'a_OPTLABEL) (loc : int * int) -> + (Qast.Node ("TyOlb", [Qast.Loc; i; t]) : 'ctyp)); + [Gramext.Snterm + (Grammar.Entry.obj + (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e)); + Gramext.Stoken ("", ":"); Gramext.Sself], + Gramext.action + (fun (t : 'ctyp) _ (i : 'a_QUESTIONIDENT) (loc : int * int) -> + (Qast.Node ("TyOlb", [Qast.Loc; i; t]) : 'ctyp)); + [Gramext.Snterm + (Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e)); + Gramext.Sself], + Gramext.action + (fun (t : 'ctyp) (i : 'a_LABEL) (loc : int * int) -> + (Qast.Node ("TyLab", [Qast.Loc; i; t]) : 'ctyp)); + [Gramext.Snterm + (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e)); + Gramext.Stoken ("", ":"); Gramext.Sself], + Gramext.action + (fun (t : 'ctyp) _ (i : 'a_TILDEIDENT) (loc : int * int) -> + (Qast.Node ("TyLab", [Qast.Loc; i; t]) : 'ctyp))]; None, Some Gramext.LeftA, [[Gramext.Sself; Gramext.Sself], Gramext.action @@ -3345,22 +3373,6 @@ (fun (l : 'class_longident) _ (m : 'a_UIDENT) (loc : int * int) -> (Qast.Cons (m, l) : 'class_longident))]]; Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), - Some (Gramext.After "arrow"), - [None, Some Gramext.NonA, - [[Gramext.Snterm - (Grammar.Entry.obj - (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) _ (i : 'a_QUESTIONIDENT) (loc : int * int) -> - (Qast.Node ("TyOlb", [Qast.Loc; i; t]) : 'ctyp)); - [Gramext.Snterm - (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) _ (i : 'a_TILDEIDENT) (loc : int * int) -> - (Qast.Node ("TyLab", [Qast.Loc; i; t]) : 'ctyp))]]; - Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), Some (Gramext.Level "simple"), [None, None, [[Gramext.Stoken ("", "["); Gramext.Stoken ("", "<"); @@ -3518,6 +3530,30 @@ (fun (i : 'a_QUESTIONIDENT) (loc : int * int) -> (Qast.Node ("PaOlb", [Qast.Loc; i; Qast.Option None]) : 'patt)); [Gramext.Snterm + (Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e)); + Gramext.Stoken ("", "("); + Gramext.Snterm + (Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e)); + Gramext.srules + [[Gramext.Sopt + (Gramext.Snterm + (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))], + Gramext.action + (fun (a : 'eq_expr option) (loc : int * int) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm + (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; + Gramext.Stoken ("", ")")], + Gramext.action + (fun _ (eo : 'a_opt) (p : 'patt_tcon) _ (i : 'a_OPTLABEL) + (loc : int * int) -> + (Qast.Node + ("PaOlb", + [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]) : + 'patt)); + [Gramext.Snterm (Grammar.Entry.obj (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e)); Gramext.Stoken ("", ":"); Gramext.Stoken ("", "("); @@ -3548,6 +3584,13 @@ (fun (i : 'a_TILDEIDENT) (loc : int * int) -> (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option None]) : 'patt)); [Gramext.Snterm + (Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e)); + Gramext.Sself], + Gramext.action + (fun (p : 'patt) (i : 'a_LABEL) (loc : int * int) -> + (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option (Some p)]) : + 'patt)); + [Gramext.Snterm (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e)); Gramext.Stoken ("", ":"); Gramext.Sself], Gramext.action @@ -3606,6 +3649,30 @@ (fun (i : 'a_QUESTIONIDENT) (loc : int * int) -> (Qast.Node ("PaOlb", [Qast.Loc; i; Qast.Option None]) : 'ipatt)); [Gramext.Snterm + (Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e)); + Gramext.Stoken ("", "("); + Gramext.Snterm + (Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e)); + Gramext.srules + [[Gramext.Sopt + (Gramext.Snterm + (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))], + Gramext.action + (fun (a : 'eq_expr option) (loc : int * int) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm + (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; + Gramext.Stoken ("", ")")], + Gramext.action + (fun _ (eo : 'a_opt) (p : 'ipatt_tcon) _ (i : 'a_OPTLABEL) + (loc : int * int) -> + (Qast.Node + ("PaOlb", + [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]) : + 'ipatt)); + [Gramext.Snterm (Grammar.Entry.obj (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e)); Gramext.Stoken ("", ":"); Gramext.Stoken ("", "("); @@ -3636,6 +3703,13 @@ (fun (i : 'a_TILDEIDENT) (loc : int * int) -> (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option None]) : 'ipatt)); [Gramext.Snterm + (Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e)); + Gramext.Sself], + Gramext.action + (fun (p : 'ipatt) (i : 'a_LABEL) (loc : int * int) -> + (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option (Some p)]) : + 'ipatt)); + [Gramext.Snterm (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e)); Gramext.Stoken ("", ":"); Gramext.Sself], Gramext.action @@ -3669,6 +3743,13 @@ (fun (i : 'a_QUESTIONIDENT) (loc : int * int) -> (Qast.Node ("ExOlb", [Qast.Loc; i; Qast.Option None]) : 'expr)); [Gramext.Snterm + (Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e)); + Gramext.Sself], + Gramext.action + (fun (e : 'expr) (i : 'a_OPTLABEL) (loc : int * int) -> + (Qast.Node ("ExOlb", [Qast.Loc; i; Qast.Option (Some e)]) : + 'expr)); + [Gramext.Snterm (Grammar.Entry.obj (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e)); Gramext.Stoken ("", ":"); Gramext.Sself], @@ -3682,6 +3763,13 @@ (fun (i : 'a_TILDEIDENT) (loc : int * int) -> (Qast.Node ("ExLab", [Qast.Loc; i; Qast.Option None]) : 'expr)); [Gramext.Snterm + (Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e)); + Gramext.Sself], + Gramext.action + (fun (e : 'expr) (i : 'a_LABEL) (loc : int * int) -> + (Qast.Node ("ExLab", [Qast.Loc; i; Qast.Option (Some e)]) : + 'expr)); + [Gramext.Snterm (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e)); Gramext.Stoken ("", ":"); Gramext.Sself], Gramext.action @@ -4427,6 +4515,11 @@ Gramext.action (fun (a : string) _ (loc : int * int) -> (antiquot "" loc a : 'a_TILDEIDENT))]]; + Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e), None, + [None, None, + [[Gramext.Stoken ("LABEL", "")], + Gramext.action + (fun (s : string) (loc : int * int) -> (Qast.Str s : 'a_LABEL))]]; Grammar.Entry.obj (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e), None, [None, None, @@ -4437,7 +4530,12 @@ [Gramext.Stoken ("", "?"); Gramext.Stoken ("ANTIQUOT", "")], Gramext.action (fun (a : string) _ (loc : int * int) -> - (antiquot "" loc a : 'a_QUESTIONIDENT))]]];; + (antiquot "" loc a : 'a_QUESTIONIDENT))]]; + Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e), None, + [None, None, + [[Gramext.Stoken ("OPTLABEL", "")], + Gramext.action + (fun (s : string) (loc : int * int) -> (Qast.Str s : 'a_OPTLABEL))]]];; let apply_entry e = let f s = Grammar.Entry.parse e (Stream.of_string s) in Index: csl/emacs/Makefile diff -u csl/emacs/Makefile:1.15 csl/emacs/Makefile:1.16 --- csl/emacs/Makefile:1.15 Fri Aug 29 17:38:28 2003 +++ csl/emacs/Makefile Fri Oct 10 15:25:38 2003 @@ -24,6 +24,7 @@ (byte-compile-file "caml.el") \ (byte-compile-file "inf-caml.el") \ (byte-compile-file "caml-help.el") \ + (byte-compile-file "caml-types.el") \ (byte-compile-file "camldebug.el")) install: Index: csl/emacs/caml-emacs.el diff -u csl/emacs/caml-emacs.el:1.4 csl/emacs/caml-emacs.el:1.5 --- csl/emacs/caml-emacs.el:1.4 Mon Aug 25 17:01:20 2003 +++ csl/emacs/caml-emacs.el Fri Oct 10 15:25:38 2003 @@ -8,7 +8,7 @@ (defun caml-event-window (e) (posn-window (event-start e))) (defun caml-event-point-start (e) (posn-point (event-start e))) (defun caml-event-point-end (e) (posn-point (event-end e))) -(defalias 'caml-track-mouse 'track-mouse) (defalias 'caml-read-event 'read-event) +(defmacro caml-track-mouse (&rest body) (cons 'track-mouse body)) (provide 'caml-emacs) Index: csl/emacs/caml-types.el diff -u csl/emacs/caml-types.el:1.24 csl/emacs/caml-types.el:1.26 --- csl/emacs/caml-types.el:1.24 Fri Sep 5 20:01:46 2003 +++ csl/emacs/caml-types.el Sat Oct 11 02:00:14 2003 @@ -21,6 +21,8 @@ (require 'caml-xemacs) (require 'caml-emacs))) + + (defvar caml-types-location-re nil "Regexp to parse *.annot files. Annotation files *.annot may be generated with the \"-dtypes\" option @@ -160,8 +162,10 @@ (target-file (file-name-nondirectory (buffer-file-name))) (target-date (nth 5 (file-attributes target-file)))) (unless (and caml-types-annotation-tree + type-date + caml-types-annotation-date (not (caml-types-date< caml-types-annotation-date type-date))) - (if (caml-types-date< type-date target-date) + (if (and type-date target-date (caml-types-date< type-date target-date)) (error (format "%s is more recent than %s" target-file type-file))) (message "Reading annotation file...") (let* ((type-buf (caml-types-find-file type-file)) @@ -376,10 +380,13 @@ (with-current-buffer buf (toggle-read-only 1)) ) (t - (error "No annotation file. You may compile with \"-dtypes\" option")) + (error "No annotation file. You should compile with option \"-dtypes\".")) ) buf)) +(defun caml-types-mouse-ignore (event) + (interactive "e") + nil) (defun caml-types-explore (event) "Explore type annotations by mouse dragging. @@ -395,58 +402,79 @@ (target-line) (target-bol) target-pos Left Right limits cnum node mes type - (tree caml-types-annotation-tree) region + target-tree ) - (caml-types-preprocess type-file) - (unless caml-types-buffer - (setq caml-types-buffer (get-buffer-create caml-types-buffer-name))) - ;; (message "Drag the mouse to explore types") (unwind-protect - (caml-track-mouse - (setq region - (caml-types-typed-make-overlay target-buf - (caml-event-point-start event))) - (while (and event - (integer-or-marker-p - (setq cnum (caml-event-point-end event)))) - (if (and region (<= (car region) cnum) (<= cnum (cdr region))) - (if (and limits (>= cnum (car limits)) (< cnum (cdr limits))) - (message mes) - (setq target-bol - (save-excursion (goto-char cnum) - (caml-line-beginning-position))) - (setq target-line - (1+ (count-lines (point-min) target-bol))) - (setq target-pos (vector target-file target-line target-bol cnum)) - (save-excursion - (setq node (caml-types-find-location target-pos () tree)) - (set-buffer caml-types-buffer) - (erase-buffer) - (cond - (node - (setq Left (caml-types-get-pos target-buf (elt node 0))) - (setq Right (caml-types-get-pos target-buf (elt node 1))) - (move-overlay caml-types-expr-ovl Left Right target-buf) - (setq limits (caml-types-find-interval target-buf target-pos - node)) - (setq type (elt node 2)) - ) - (t - (delete-overlay caml-types-expr-ovl) - (setq type "*no type information*") - (setq limits (caml-types-find-interval target-buf target-pos - tree)) - )) - (message (setq mes (format "type: %s" type))) - (insert type) - ))) - (setq event (caml-read-event)) - (unless (mouse-movement-p event) (setq event nil)) - ) - ) - (delete-overlay caml-types-expr-ovl) - (delete-overlay caml-types-typed-ovl) + (progn + (caml-types-preprocess type-file) + (setq target-tree caml-types-annotation-tree) + (unless caml-types-buffer + (setq caml-types-buffer + (get-buffer-create caml-types-buffer-name))) + ;; (message "Drag the mouse to explore types") + (unwind-protect + (caml-track-mouse + (setq region + (caml-types-typed-make-overlay + target-buf (caml-event-point-start event))) + (while (and event + (integer-or-marker-p + (setq cnum (caml-event-point-end event)))) + (if (and region (<= (car region) cnum) (< cnum (cdr region))) + (if (and limits + (>= cnum (car limits)) (< cnum (cdr limits))) + (message mes) + (setq target-bol + (save-excursion + (goto-char cnum) (caml-line-beginning-position)) + target-line (1+ (count-lines (point-min) + target-bol)) + target-pos + (vector target-file target-line target-bol cnum)) + (save-excursion + (setq node (caml-types-find-location + target-pos () target-tree)) + (set-buffer caml-types-buffer) + (erase-buffer) + (cond + (node + (setq Left + (caml-types-get-pos target-buf (elt node 0)) + Right + (caml-types-get-pos target-buf (elt node 1))) + (move-overlay + caml-types-expr-ovl Left Right target-buf) + (setq limits + (caml-types-find-interval target-buf + target-pos node) + type (elt node 2)) + ) + (t + (delete-overlay caml-types-expr-ovl) + (setq type "*no type information*") + (setq limits + (caml-types-find-interval + target-buf target-pos target-tree)) + )) + (message (setq mes (format "type: %s" type))) + (insert type) + ))) + (setq event (caml-read-event)) + (unless (mouse-movement-p event) (setq event nil)) + ) + ) + (delete-overlay caml-types-expr-ovl) + (delete-overlay caml-types-typed-ovl) + )) + ;; the mouse is down. One should prevent against mouse release, + ;; which could do something undesirable. + ;; In most common cases, next event will be mouse release. + ;; However, it could also be a key stroke before mouse release. + ;; Will then execute the action for mouse release (if bound). + ;; Emacs does not allow to test whether mouse is up or down. + ;; Same problem may happen above while exploring + (if (and event (caml-read-event))) ))) (defun caml-types-typed-make-overlay (target-buf pos) @@ -459,7 +487,7 @@ (if (and (equal target-buf (current-buffer)) (setq left (caml-types-get-pos target-buf (elt node 0)) right (caml-types-get-pos target-buf (elt node 1))) - (<= left pos) (>= right pos) + (<= left pos) (> right pos) ) (setq start (min start left) end (max end right)) Index: csl/emacs/caml-xemacs.el diff -u csl/emacs/caml-xemacs.el:1.3 csl/emacs/caml-xemacs.el:1.4 --- csl/emacs/caml-xemacs.el:1.3 Tue Jul 29 09:30:03 2003 +++ csl/emacs/caml-xemacs.el Fri Oct 10 15:25:38 2003 @@ -12,8 +12,9 @@ (defun caml-event-window (e) (event-window e)) (defun caml-event-point-start (e) (event-closest-point e)) (defun caml-event-point-end (e) (event-closest-point e)) -(defalias 'caml-track-mouse 'progn) (defalias 'caml-read-event 'next-event) +(defmacro caml-track-mouse (&rest body) (cons 'progn body)) + (defun mouse-movement-p (e) (equal (event-type e) 'motion)) (provide 'caml-xemacs) Index: csl/emacs/caml.el diff -u csl/emacs/caml.el:1.34 csl/emacs/caml.el:1.35 --- csl/emacs/caml.el:1.34 Mon Jul 28 20:06:49 2003 +++ csl/emacs/caml.el Fri Oct 10 15:25:38 2003 @@ -283,6 +283,8 @@ ;; caml-types (define-key caml-mode-map [?\C-c?\C-t] 'caml-types-show-type) + ;; to prevent misbehavior in case of error during exploration. + (define-key caml-mode-map [mouse-2] 'caml-types-mouse-ignore) (define-key caml-mode-map [down-mouse-2] 'caml-types-explore) ;; caml-help (define-key caml-mode-map [?\C-c?i] 'ocaml-add-path) Index: csl/otherlibs/threads/scheduler.c diff -u csl/otherlibs/threads/scheduler.c:1.56 csl/otherlibs/threads/scheduler.c:1.57 --- csl/otherlibs/threads/scheduler.c:1.56 Thu Mar 20 17:23:03 2003 +++ csl/otherlibs/threads/scheduler.c Fri Oct 10 15:13:21 2003 @@ -72,10 +72,10 @@ /* The thread descriptors */ -struct thread_struct { +struct caml_thread_struct { value ident; /* Unique id (for equality comparisons) */ - struct thread_struct * next; /* Double linking of threads */ - struct thread_struct * prev; + struct caml_thread_struct * next; /* Double linking of threads */ + struct caml_thread_struct * prev; value * stack_low; /* The execution stack for this thread */ value * stack_high; value * stack_threshold; @@ -94,7 +94,7 @@ value retval; /* Value to return when thread resumes */ }; -typedef struct thread_struct * thread_t; +typedef struct caml_thread_struct * caml_thread_t; #define RUNNABLE Val_int(0) #define KILLED Val_int(1) @@ -122,7 +122,7 @@ #define DELAY_INFTY 1E30 /* +infty, for this purpose */ /* The thread currently active */ -static thread_t curr_thread = NULL; +static caml_thread_t curr_thread = NULL; /* Identifier for next thread creation */ static value next_ident = Val_int(0); @@ -134,7 +134,7 @@ static void thread_scan_roots(scanning_action action) { - thread_t th, start; + caml_thread_t th, start; /* Scan all active descriptors */ start = curr_thread; @@ -161,7 +161,8 @@ if (curr_thread != NULL) return Val_unit; /* Create a descriptor for the current thread */ curr_thread = - (thread_t) alloc_shr(sizeof(struct thread_struct) / sizeof(value), 0); + (caml_thread_t) alloc_shr(sizeof(struct caml_thread_struct) + / sizeof(value), 0); curr_thread->ident = next_ident; next_ident = Val_int(Int_val(next_ident) + 1); curr_thread->next = curr_thread; @@ -218,10 +219,11 @@ value thread_new(value clos) /* ML */ { - thread_t th; + caml_thread_t th; /* Allocate the thread and its stack */ Begin_root(clos); - th = (thread_t) alloc_shr(sizeof(struct thread_struct) / sizeof(value), 0); + th = (caml_thread_t) alloc_shr(sizeof(struct caml_thread_struct) + / sizeof(value), 0); End_roots(); th->ident = next_ident; next_ident = Val_int(Int_val(next_ident) + 1); @@ -268,7 +270,7 @@ value thread_id(value th) /* ML */ { - return ((struct thread_struct *)th)->ident; + return ((caml_thread_t)th)->ident; } /* Return the current time as a floating-point number */ @@ -293,7 +295,7 @@ static value schedule_thread(void) { - thread_t run_thread, th; + caml_thread_t run_thread, th; fd_set readfds, writefds, exceptfds; double delay, now; int need_select, need_wait; @@ -353,7 +355,7 @@ } } if (th->status & (BLOCKED_JOIN - 1)) { - if (((thread_t)(th->joining))->status == KILLED) { + if (((caml_thread_t)(th->joining))->status == KILLED) { th->status = RUNNABLE; Assign(th->retval, RESUMED_JOIN); } @@ -682,7 +684,7 @@ { check_callback(); Assert(curr_thread != NULL); - if (((thread_t)th)->status == KILLED) return Val_unit; + if (((caml_thread_t)th)->status == KILLED) return Val_unit; curr_thread->status = BLOCKED_JOIN; Assign(curr_thread->joining, th); return schedule_thread(); @@ -703,7 +705,7 @@ value thread_wakeup(value thread) /* ML */ { - thread_t th = (thread_t) thread; + caml_thread_t th = (caml_thread_t) thread; switch (th->status) { case SUSPENDED: th->status = RUNNABLE; @@ -730,7 +732,7 @@ value thread_kill(value thread) /* ML */ { value retval = Val_unit; - thread_t th = (thread_t) thread; + caml_thread_t th = (caml_thread_t) thread; if (th->status == KILLED) failwith("Thread.kill: killed thread"); /* Don't paint ourselves in a corner */ if (th == th->next) failwith("Thread.kill: cannot kill the last thread"); @@ -740,7 +742,7 @@ if (th == curr_thread) { Begin_root(thread); retval = schedule_thread(); - th = (thread_t) thread; + th = (caml_thread_t) thread; End_roots(); } /* Remove thread from the doubly-linked list */ Index: csl/stdlib/buffer.mli diff -u csl/stdlib/buffer.mli:1.16 csl/stdlib/buffer.mli:1.17 --- csl/stdlib/buffer.mli:1.16 Wed May 14 19:52:19 2003 +++ csl/stdlib/buffer.mli Wed Oct 8 15:12:44 2003 @@ -74,7 +74,7 @@ - a non empty sequence of alphanumeric or [_] characters, - an arbitrary sequence of characters enclosed by a pair of matching parentheses or curly brackets. - An escaped [$] character is a [$] that immediately folows a backslash + An escaped [$] character is a [$] that immediately follows a backslash character; it then stands for a plain [$]. Raise [Not_found] if the closing character of a parenthesized variable cannot be found. *) Index: csl/stdlib/pervasives.mli diff -u csl/stdlib/pervasives.mli:1.93 csl/stdlib/pervasives.mli:1.94 --- csl/stdlib/pervasives.mli:1.93 Thu Sep 4 14:44:48 2003 +++ csl/stdlib/pervasives.mli Wed Oct 8 15:13:33 2003 @@ -800,7 +800,7 @@ external string_of_format : ('a, 'b, 'c, 'd) format4 -> string = "%identity" -(** Converts a format string into a string.*) +(** Converts a format string into a string. *) external format_of_string : ('a, 'b, 'c, 'd) format4 -> ('a, 'b, 'c, 'd) format4 = "%identity" (** [format_of_string s] returns a format string read from the string Index: csl/stdlib/sys.ml diff -u csl/stdlib/sys.ml:1.78 csl/stdlib/sys.ml:1.80 --- csl/stdlib/sys.ml:1.78 Fri Sep 12 09:46:23 2003 +++ csl/stdlib/sys.ml Mon Oct 13 09:39:46 2003 @@ -78,4 +78,4 @@ (* OCaml version string, must be in the format described in sys.mli. *) -let ocaml_version = "3.07";; +let ocaml_version = "3.07+2";;