Add a -keywords <version?+list> flag (ocaml#13471)

This commit adds a `-keywords <version?+list>` flag which takes as argument: - an optional version v number (formatted as %d.%d) - a +-separated list of additional keywords and defines the set of keywords recognized by the lexer as the set of keywords at the version `v` of OCaml (defaulting to the current version if no versions were given) completed by the list of additional keywords. This is intended to provide an easy way to keep old OCaml code with newer version of the compiler with additional keywords.
tmcgilchrist · Oct 29, 2024 · f5ff742 · f5ff742
1 parent 9caaced
commit f5ff742
Show file tree

Hide file tree

Showing 12 changed files with 189 additions and 66 deletions.
diff --git a/.depend b/.depend
@@ -451,6 +451,7 @@ parsing/parse.cmo : \
     parsing/lexer.cmi \
     utils/format_doc.cmi \
     parsing/docstrings.cmi \
+    utils/clflags.cmi \
     parsing/parse.cmi
 parsing/parse.cmx : \
     parsing/syntaxerr.cmx \
@@ -461,6 +462,7 @@ parsing/parse.cmx : \
     parsing/lexer.cmx \
     utils/format_doc.cmx \
     parsing/docstrings.cmx \
+    utils/clflags.cmx \
     parsing/parse.cmi
 parsing/parse.cmi : \
     parsing/parsetree.cmi \

diff --git a/Changes b/Changes
@@ -520,6 +520,11 @@ ___________
     The constant "42" has type ...
   (Jules Aguillon, review by Gabriel Scherer and Florian Angeletti)
 
+- #13471: add `-keywords <version?+list>` flag to define the list of keywords
+  recognized by the lexer, for instance `-keywords 5.2` disable the `effect`
+  keyword.
+  (Florian Angeletti, review by Gabriel Scherer)
+
 ### Internal/compiler-libs changes:
 
 - #11129, #11148: enforce that ppxs do not produce `parsetree`s with

diff --git a/driver/compenv.ml b/driver/compenv.ml
@@ -480,6 +480,8 @@ let read_one_param ppf position name v =
   | "dump" ->
       handle_dump_option ppf v
 
+  |  "keywords"  -> Clflags.keyword_edition := Some v
+
   | _ ->
     if not (List.mem name !can_discard) then begin
       can_discard := name :: !can_discard;

diff --git a/driver/main_args.ml b/driver/main_args.ml
@@ -407,6 +407,15 @@ let mk_ppx f =
   "-ppx", Arg.String f,
   "<command>  Pipe abstract syntax trees through preprocessor <command>"
 
+let mk_keywords f =
+  "-keywords", Arg.String f,
+  "<version+list>  set keywords following the <version+list> spec:\n
+  \                -<version> if present specifies the base set of keywords\n
+  \                  (if absent the current set of keywords is used)
+  \                -<list> is a \"+\"-separated list of keywords to add to\n
+  \                  the base set of keywords.
+  "
+
 let mk_plugin f =
   "-plugin", Arg.String f,
   "<plugin>  (no longer supported)"
@@ -785,6 +794,7 @@ module type Common_options = sig
   val _nocwd : unit -> unit
   val _open : string -> unit
   val _ppx : string -> unit
+  val _keywords: string -> unit
   val _principal : unit -> unit
   val _no_principal : unit -> unit
   val _rectypes : unit -> unit
@@ -1057,6 +1067,7 @@ struct
     mk_no_keep_docs F._no_keep_docs;
     mk_keep_locs F._keep_locs;
     mk_no_keep_locs F._no_keep_locs;
+    mk_keywords F._keywords;
     mk_labels F._labels;
     mk_linkall F._linkall;
     mk_make_runtime F._make_runtime;
@@ -1166,6 +1177,7 @@ struct
     mk_nopervasives F._nopervasives;
     mk_open F._open;
     mk_ppx F._ppx;
+    mk_keywords F._keywords;
     mk_principal F._principal;
     mk_no_principal F._no_principal;
     mk_rectypes F._rectypes;
@@ -1264,6 +1276,7 @@ struct
     mk_no_keep_docs F._no_keep_docs;
     mk_keep_locs F._keep_locs;
     mk_no_keep_locs F._no_keep_locs;
+    mk_keywords F._keywords;
     mk_labels F._labels;
     mk_linkall F._linkall;
     mk_inline_max_depth F._inline_max_depth;
@@ -1401,6 +1414,7 @@ module Make_opttop_options (F : Opttop_options) = struct
     mk_inline_indirect_cost F._inline_indirect_cost;
     mk_inline_lifting_benefit F._inline_lifting_benefit;
     mk_inline_branch_factor F._inline_branch_factor;
+    mk_keywords F._keywords;
     mk_labels F._labels;
     mk_alias_deps F._alias_deps;
     mk_no_alias_deps F._no_alias_deps;
@@ -1499,6 +1513,7 @@ struct
     mk_intf F._intf;
     mk_intf_suffix F._intf_suffix;
     mk_intf_suffix_2 F._intf_suffix;
+    mk_keywords F._keywords;
     mk_labels F._labels;
     mk_modern F._labels;
     mk_alias_deps F._alias_deps;
@@ -1640,6 +1655,7 @@ module Default = struct
       Misc.set_or_ignore error_style_reader.parse error_style
     let _nopervasives = set nopervasives
     let _ppx s = Compenv.first_ppx := (s :: (!Compenv.first_ppx))
+    let _keywords s = Clflags.keyword_edition := (Some s)
     let _unsafe = set unsafe
     let _warn_error s =
       Warnings.parse_options true s |> Option.iter Location.(prerr_alert none)
@@ -1893,6 +1909,7 @@ module Default = struct
     let _intf_suffix s = Config.interface_suffix := s
     let _pp s = Clflags.preprocessor := (Some s)
     let _ppx s = Clflags.all_ppx := (s :: (!Clflags.all_ppx))
+    let _keywords s = Clflags.keyword_edition := Some s
     let _thread = set Clflags.use_threads
     let _v () = Compenv.print_version_and_library "documentation generator"
     let _verbose = set Clflags.verbose

diff --git a/driver/main_args.mli b/driver/main_args.mli
@@ -33,6 +33,7 @@ module type Common_options = sig
   val _nocwd : unit -> unit
   val _open : string -> unit
   val _ppx : string -> unit
+  val _keywords: string -> unit
   val _principal : unit -> unit
   val _no_principal : unit -> unit
   val _rectypes : unit -> unit

diff --git a/man/ocamlc.1 b/man/ocamlc.1
@@ -453,6 +453,22 @@ Keep documentation strings in generated .cmi files.
 .TP
 .B \-keep-locs
 Keep locations in generated .cmi files.
+.TP
+.BI \-keywords " version+list"
+Set keywords according to the
+.IR version+list
+specification.
+
+This specification starts with an optional version number, defining the base
+set of keywords, followed by a
+.IR +
+separated list of additional keywords to add to this base set.
+Without an explicit version number, the base set of keywords is the
+set of keywords in the current version of OCaml.
+Additional keywords that do not match any known keyword in the current
+version of the language trigger an error whenever they are present in the
+source code.
+
 .TP
 .B \-labels
 Labels are not ignored in types, labels may be used in applications,

diff --git a/manual/src/cmds/unified-options.etex b/manual/src/cmds/unified-options.etex
@@ -363,6 +363,20 @@ Recognize file names ending with \var{string} as interface files
 (instead of the default ".mli").
 }%\notop
 
+\item["-keywords" \var{version+list}]
+Set keywords according to the \var{version+list}
+specification.
+
+This specification starts with an optional version number, defining the base set
+of keywords, followed by a \var{+}-separated list of additional keywords to add
+to this base set.
+
+Without an explicit version number, the base set of keywords is the
+set of keywords in the current version of OCaml.
+Additional keywords that do not match any known keyword in the current
+version of the language trigger an error whenever they are present in the
+source code.
+
 \item["-labels"]
 Labels are not ignored in types, labels may be used in applications,
 and labelled parameters can be given in any order.  This is the default.

diff --git a/parsing/lexer.mli b/parsing/lexer.mli
@@ -20,7 +20,7 @@
 
 *)
 
-val init : unit -> unit
+val init : ?keyword_edition:((int*int) option * string list) -> unit -> unit
 val token: Lexing.lexbuf -> Parser.token
 val skip_hash_bang: Lexing.lexbuf -> unit
 
@@ -40,6 +40,7 @@ type error =
   | Invalid_char_in_ident of Uchar.t
   | Non_lowercase_delimiter of string
   | Capitalized_raw_identifier of string
+  | Unknown_keyword of string
 
 exception Error of error * Location.t
 

diff --git a/parsing/lexer.mll b/parsing/lexer.mll
@@ -36,74 +36,102 @@ type error =
   | Invalid_char_in_ident of Uchar.t
   | Non_lowercase_delimiter of string
   | Capitalized_raw_identifier of string
+  | Unknown_keyword of string
 
 exception Error of error * Location.t
 
 (* The table of keywords *)
 
-let keyword_table =
-  create_hashtable 149 [
-    "and", AND;
-    "as", AS;
-    "assert", ASSERT;
-    "begin", BEGIN;
-    "class", CLASS;
-    "constraint", CONSTRAINT;
-    "do", DO;
-    "done", DONE;
-    "downto", DOWNTO;
-    "effect", EFFECT;
-    "else", ELSE;
-    "end", END;
-    "exception", EXCEPTION;
-    "external", EXTERNAL;
-    "false", FALSE;
-    "for", FOR;
-    "fun", FUN;
-    "function", FUNCTION;
-    "functor", FUNCTOR;
-    "if", IF;
-    "in", IN;
-    "include", INCLUDE;
-    "inherit", INHERIT;
-    "initializer", INITIALIZER;
-    "lazy", LAZY;
-    "let", LET;
-    "match", MATCH;
-    "method", METHOD;
-    "module", MODULE;
-    "mutable", MUTABLE;
-    "new", NEW;
-    "nonrec", NONREC;
-    "object", OBJECT;
-    "of", OF;
-    "open", OPEN;
-    "or", OR;
+let all_keywords =
+  let v5_3 = Some (5,3) in
+  let v1_0 = Some (1,0) in
+  let v1_6 = Some (1,6) in
+  let v4_2 = Some (4,2) in
+  let always = None in
+  [
+    "and", AND, always;
+    "as", AS, always;
+    "assert", ASSERT, v1_6;
+    "begin", BEGIN, always;
+    "class", CLASS, v1_0;
+    "constraint", CONSTRAINT, v1_0;
+    "do", DO, always;
+    "done", DONE, always;
+    "downto", DOWNTO, always;
+    "effect", EFFECT, v5_3;
+    "else", ELSE, always;
+    "end", END, always;
+    "exception", EXCEPTION, always;
+    "external", EXTERNAL, always;
+    "false", FALSE, always;
+    "for", FOR, always;
+    "fun", FUN, always;
+    "function", FUNCTION, always;
+    "functor", FUNCTOR, always;
+    "if", IF, always;
+    "in", IN, always;
+    "include", INCLUDE, always;
+    "inherit", INHERIT, v1_0;
+    "initializer", INITIALIZER, v1_0;
+    "lazy", LAZY, v1_6;
+    "let", LET, always;
+    "match", MATCH, always;
+    "method", METHOD, v1_0;
+    "module", MODULE, always;
+    "mutable", MUTABLE, always;
+    "new", NEW, v1_0;
+    "nonrec", NONREC, v4_2;
+    "object", OBJECT, v1_0;
+    "of", OF, always;
+    "open", OPEN, always;
+    "or", OR, always;
 (*  "parser", PARSER; *)
-    "private", PRIVATE;
-    "rec", REC;
-    "sig", SIG;
-    "struct", STRUCT;
-    "then", THEN;
-    "to", TO;
-    "true", TRUE;
-    "try", TRY;
-    "type", TYPE;
-    "val", VAL;
-    "virtual", VIRTUAL;
-    "when", WHEN;
-    "while", WHILE;
-    "with", WITH;
-
-    "lor", INFIXOP3("lor"); (* Should be INFIXOP2 *)
-    "lxor", INFIXOP3("lxor"); (* Should be INFIXOP2 *)
-    "mod", INFIXOP3("mod");
-    "land", INFIXOP3("land");
-    "lsl", INFIXOP4("lsl");
-    "lsr", INFIXOP4("lsr");
-    "asr", INFIXOP4("asr")
+    "private", PRIVATE, v1_0;
+    "rec", REC, always;
+    "sig", SIG, always;
+    "struct", STRUCT, always;
+    "then", THEN, always;
+    "to", TO, always;
+    "true", TRUE, always;
+    "try", TRY, always;
+    "type", TYPE, always;
+    "val", VAL, always;
+    "virtual", VIRTUAL, v1_0;
+    "when", WHEN, always;
+    "while", WHILE, always;
+    "with", WITH, always;
+
+    "lor", INFIXOP3("lor"), always; (* Should be INFIXOP2 *)
+    "lxor", INFIXOP3("lxor"), always; (* Should be INFIXOP2 *)
+    "mod", INFIXOP3("mod"), always;
+    "land", INFIXOP3("land"), always;
+    "lsl", INFIXOP4("lsl"), always;
+    "lsr", INFIXOP4("lsr"), always;
+    "asr", INFIXOP4("asr"), always
 ]
 
+
+let keyword_table = Hashtbl.create 149
+
+let populate_keywords (version,keywords) =
+  let greater (x:(int*int) option) (y:(int*int) option) =
+    match x, y with
+    | None, _ | _, None -> true
+    | Some x, Some y -> x >= y
+  in
+  let tbl = keyword_table in
+  Hashtbl.clear tbl;
+  let add_keyword (name, token, since) =
+    if greater version since then Hashtbl.replace tbl name (Some token)
+  in
+  List.iter add_keyword all_keywords;
+  List.iter (fun name ->
+    match List.find (fun (n,_,_) -> n = name) all_keywords with
+    | (_,tok,_) -> Hashtbl.replace tbl name (Some tok)
+    | exception Not_found -> Hashtbl.replace tbl name None
+    ) keywords
+
+
 (* To buffer string literals *)
 
 let string_buffer = Buffer.create 256
@@ -294,7 +322,14 @@ let lax_delim raw_name =
      if Utf8_lexeme.is_lowercase name then Some name
      else None
 
-let is_keyword name = Hashtbl.mem keyword_table name
+let is_keyword name =
+  Hashtbl.mem keyword_table name
+
+let find_keyword lexbuf name =
+  match Hashtbl.find keyword_table name with
+  | Some x -> x
+  | None -> error lexbuf (Unknown_keyword name)
+  | exception Not_found -> LIDENT name
 
 let check_label_name ?(raw_escape=false) lexbuf name =
   if Utf8_lexeme.is_capitalized name then
@@ -395,6 +430,11 @@ let prepare_error loc = function
         "%a cannot be used as a quoted string delimiter,@ \
          it must contain only lowercase letters."
          Style.inline_code name
+  | Unknown_keyword name ->
+      Location.errorf ~loc
+      "%a has been defined as an additional keyword.@ \
+       This version of OCaml does not support this keyword."
+      Style.inline_code name
 
 let () =
   Location.register_error_of_exn
@@ -489,8 +529,7 @@ rule token = parse
         OPTLABEL name
       }
   | lowercase identchar * as name
-      { try Hashtbl.find keyword_table name
-        with Not_found -> LIDENT name }
+      { find_keyword lexbuf name }
   | uppercase identchar * as name
       { UIDENT name } (* No capitalized keywords *)
   | (raw_ident_escape? as escape) (ident_ext as raw_name)
@@ -960,7 +999,8 @@ and skip_hash_bang = parse
     in
       loop NoLine Initial lexbuf
 
-  let init () =
+  let init ?(keyword_edition=None,[]) () =
+    populate_keywords keyword_edition;
     is_in_string := false;
     comment_start_loc := [];
     comment_list := [];