#6583: support for custom #... binary operators (also allowing '#' in trailing symbols, although the operator is then rejected by the type-checker).

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@15892 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

3 files changed, 23 insertions, 1 deletions

diff --git a/typing/env.ml b/typing/env.ml
index d4f2e312d5..f3b07d9daa 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -58,6 +58,7 @@ type error =
   | Inconsistent_import of string * string * string
   | Need_recursive_types of string * string
   | Missing_module of Location.t * Path.t * Path.t
+  | Illegal_value_name of Location.t * string
 
 exception Error of error
 
@@ -1337,7 +1338,20 @@ and check_usage loc id warn tbl =
         (fun () -> if not !used then Location.prerr_warning loc (warn name))
   end;
 
+and check_value_name name loc =
+  (* Note: we could also check here general validity of the
+     identifier, to protect against bad identifiers forged by -pp or
+     -ppx preprocessors. *)
+
+  if String.length name > 0 && (name.[0] = '#') then
+    for i = 1 to String.length name - 1 do
+      if name.[i] = '#' then
+        raise (Error(Illegal_value_name(loc, name)))
+    done
+
+
 and store_value ?check slot id path decl env renv =
+  check_value_name (Ident.name id) decl.val_loc;
   may (fun f -> check_usage decl.val_loc id f value_declarations) check;
   { env with
     values = EnvTbl.add "value" slot id (path, decl) env.values renv.values;
@@ -1848,11 +1862,16 @@ let report_error ppf = function
       fprintf ppf "@]@ @[%s@ %s@ %s.@]@]"
         "The compiled interface for module" (Ident.name (Path.head path2))
         "was not found"
+  | Illegal_value_name(_loc, name) ->
+      fprintf ppf "'%s' is not a valid value identifier."
+        name
 
 let () =
   Location.register_error_of_exn
     (function
-      | Error (Missing_module (loc, _, _) as err) when loc <> Location.none ->
+      | Error (Missing_module (loc, _, _)
+              | Illegal_value_name (loc, _)
+               as err) when loc <> Location.none ->
           Some (Location.error_of_printer loc report_error err)
       | Error err -> Some (Location.error_of_printer_file report_error err)
       | _ -> None
diff --git a/typing/env.mli b/typing/env.mli
index 03ee4ad96a..8723185258 100644
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -192,6 +192,7 @@ type error =
   | Inconsistent_import of string * string * string
   | Need_recursive_types of string * string
   | Missing_module of Location.t * Path.t * Path.t
+  | Illegal_value_name of Location.t * string
 
 exception Error of error
 
@@ -261,3 +262,4 @@ val fold_cltypes:
 
 (** Utilities *)
 val scrape_alias: t -> module_type -> module_type
+val check_value_name: string -> Location.t -> unit
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index 930b517c80..0756f8dfe9 100644
--- a/typing/typetexp.ml
+++ b/typing/typetexp.ml
@@ -251,6 +251,7 @@ let find_class env loc lid =
   r
 
 let find_value env loc lid =
+  Env.check_value_name (Longident.last lid) loc;
   let (path, decl) as r =
     find_component Env.lookup_value (fun lid -> Unbound_value lid) env loc lid
   in