3.10.0+beta: Corrected and improved Camlp4MacroParser

[Aleksey Nogin <nogin@metaprl.org>]

[-- Attachment #1: Type: text/plain, Size: 1321 bytes --]

As I wrote to the list earlier, I have noticed that the 
Camlp4MacroParser in 3.10.0+beta has an unfortunate problem - when 
processing an "IFDEF" (or "IFNDEF") directive, it will execute the 
"DEFINE"s in _both_ branches, regardless of whether the test is true or 
not (this was caused by the fact that the DEFINE directives would be 
executed eagerly at parse-time).

Attached is a corrected and improved version of the Camlp4MacroParser:

- Fixes the above problem; now the execution of the "DEFINE" directives 
inside IFDEF/IFNDEF is correct.

- Adds support for "local" definitions
   DEFINE <lident> = <expression> IN <expression>
   This is particularly useful for things like

   DEFINE body =
     ...
   IN
   IFDEF DEBUG
     let result = body in
     print_debug result;
     result
   ELSE
     body

- Adds an ability to omit the "ELSE" part of the IFDEF/IFNDEF 
expressions (the "ELSE" branch is then taken to default to unit 
expression "()").

- Adds an ability to use the macro argument as a pattern (provided the 
argument is a sufficiently simple expression)

- Adds a special macro "NOTHING" that can be used to "wipe out" unneeded 
function arguments. This is useful to be able to generate functions of 
different arity using the same macro.

The improved Camlp4MacroParser.ml is attached.

Aleksey

[-- Attachment #2: Camlp4MacroParser.ml --]
[-- Type: text/plain, Size: 12376 bytes --]

open Camlp4;                                             (* -*- camlp4r -*- *)
(****************************************************************************)
(*                                                                          *)
(*                              Objective Caml                              *)
(*                                                                          *)
(*                            INRIA Rocquencourt                            *)
(*                                                                          *)
(*  Copyright  2006   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 LICENSE at the top of the Objective   *)
(*  Caml source tree.                                                       *)
(*                                                                          *)
(****************************************************************************)

(* Authors:
 * - Daniel de Rauglaudre: initial version
 * - Nicolas Pouillard: refactoring
 * - Aleksey Nogin: extra features and bug fixes.
 *)

module Id = struct
  value name = "Camlp4MacroParser";
  value version = "$Id: Camlp4MacroParser.ml,v 1.1 2007/02/07 10:09:22 ertai Exp $";
end;

(*
Added statements:

  At toplevel (structure item):

     DEFINE <uident>
     DEFINE <uident> = <expression>
     DEFINE <uident> (<parameters>) = <expression>
     IFDEF <uident> THEN <structure_items> [ ELSE <structure_items> ] (END | ENDIF)
     IFNDEF <uident> THEN <structure_items> [ ELSE <structure_items> ] (END | ENDIF)
     INCLUDE <string>

  In expressions:

     IFDEF <uident> THEN <expression> [ ELSE <expression> ] (END | ENDIF)
     IFNDEF <uident> THEN <expression> [ ELSE <expression> ] (END | ENDIF)
     DEFINE <lident> = <expression> IN <expression>
     __FILE__
     __LOCATION__

  In patterns:

     IFDEF <uident> THEN <pattern> ELSE <pattern> (END | ENDIF)
     IFNDEF <uident> THEN <pattern> ELSE <pattern> (END | ENDIF)

  As Camlp4 options:

     -D<uident>                      define <uident>
     -U<uident>                      undefine it
     -I<dir>                         add <dir> to the search path for INCLUDE'd files

  After having used a DEFINE <uident> followed by "= <expression>", you
  can use it in expressions *and* in patterns. If the expression defining
  the macro cannot be used as a pattern, there is an error message if
  it is used in a pattern.

  You can also define a local macro in an expression usigng the DEFINE ... IN form.
  Note that local macros have lowercase names and can not take parameters.

  If a macro is defined to = NOTHING, and then used as an argument to a function,
  this will be equivalent to function taking one less argument. Similarly,
  passing NOTHING as an argument to a macro is equivalent to "erasing" the
  corresponding parameter from the macro body.

  The toplevel statement INCLUDE <string> can be used to include a
  file containing macro definitions and also any other toplevel items.
  The included files are looked up in directories passed in via the -I
  option, falling back to the current directory.

  The expression __FILE__ returns the current compiled file name.
  The expression __LOCATION__ returns the current location of itself.

*)

open Camlp4;

module Make (Syntax : Sig.Camlp4Syntax) = struct
  open Sig;
  include Syntax;

  type item_or_def 'a =
    [ SdStr of 'a
    | SdDef of string and option (list string * Ast.expr)
    | SdUnd of string
    | SdITE of string and list (item_or_def 'a) and list (item_or_def 'a)
    | SdInc of string ];

  value rec list_remove x =
    fun
    [ [(y, _) :: l] when y = x -> l
    | [d :: l] -> [d :: list_remove x l]
    | [] -> [] ];

  value defined = ref [];

  value is_defined i = List.mem_assoc i defined.val;

  value bad_patt _loc = 
    Loc.raise _loc
      (Failure
         "this macro cannot be used in a pattern (see its definition)");
  value substp _loc env =
    loop where rec loop =
      fun
      [ <:expr< $e1$ $e2$ >> -> <:patt< $loop e1$ $loop e2$ >>
      | <:expr< >> -> <:patt< >>
      | <:expr< $lid:x$ >> ->
          try List.assoc x env with
          [ Not_found -> <:patt< $lid:x$ >> ]
      | <:expr< $uid:x$ >> ->
          try List.assoc x env with
          [ Not_found -> <:patt< $uid:x$ >> ]
      | <:expr< $int:x$ >> -> <:patt< $int:x$ >>
      | <:expr< $str:s$ >> -> <:patt< $str:s$ >>
      | <:expr< ($tup:x$) >> -> <:patt< ($tup:loop x$) >>
      | <:expr< $x1$, $x2$ >> -> <:patt< $loop x1$, $loop x2$ >>
      | <:expr< { $bi$ } >> ->
          let rec substbi = fun
            [ <:binding< $b1$; $b2$ >> -> <:patt< $substbi b1$; $substbi b2$ >>
            | <:binding< $p$ = $e$ >> -> <:patt< $p$ = $loop e$ >>
            | _ -> bad_patt _loc ]
          in <:patt< { $substbi bi$ } >>
      | _ -> bad_patt _loc ];

  class reloc _loc = object
    inherit Ast.map as super;
    method _Loc_t _ = _loc;
  end;

  class subst _loc env = object
    inherit reloc _loc as super;
    method expr =
      fun
      [ <:expr< $lid:x$ >> | <:expr< $uid:x$ >> as e ->
          try List.assoc x env with
          [ Not_found -> super#expr e ]
      | e -> super#expr e ];

    method patt =
      fun
      [ <:patt< $lid:x$ >> | <:patt< $uid:x$ >> as p ->
         try substp _loc [] (List.assoc x env) with
         [ Not_found -> super#patt p ]
      | p -> super#patt p ];
  end;

  value incorrect_number loc l1 l2 =
    Loc.raise loc
      (Failure
        (Printf.sprintf "expected %d parameters; found %d"
            (List.length l2) (List.length l1)));

  value define eo x =
    do {
      match eo with
      [ Some ([], e) ->
          EXTEND Gram
            expr: LEVEL "simple"
              [ [ UIDENT $x$ -> (new reloc _loc)#expr e ]]
            ;
            patt: LEVEL "simple"
              [ [ UIDENT $x$ ->
                    let p = substp _loc [] e
                    in (new reloc _loc)#patt p ]]
            ;
          END
      | Some (sl, e) ->
          EXTEND Gram
            expr: LEVEL "apply"
              [ [ UIDENT $x$; param = SELF ->
                    let el =
                      match param with
                      [ <:expr< ($tup:e$) >> -> Ast.list_of_expr e []
                      | e -> [e] ]
                    in
                    if List.length el = List.length sl then
                      let env = List.combine sl el in
                      (new subst _loc env)#expr e
                    else
                      incorrect_number _loc el sl ] ]
            ;
            patt: LEVEL "simple"
              [ [ UIDENT $x$; param = SELF ->
                    let pl =
                      match param with
                      [ <:patt< ($tup:p$) >> -> Ast.list_of_patt p []
                      | p -> [p] ]
                    in
                    if List.length pl = List.length sl then
                      let env = List.combine sl pl in
                      let p = substp _loc env e in
                      (new reloc _loc)#patt p
                    else
                      incorrect_number _loc pl sl ] ]
            ;
          END
      | None -> () ];
      defined.val := [(x, eo) :: defined.val];
    };

  value undef x =
    try
      do {
        let eo = List.assoc x defined.val in
        match eo with
        [ Some ([], _) ->
            do {
              DELETE_RULE Gram expr: UIDENT $x$ END;
              DELETE_RULE Gram patt: UIDENT $x$ END;
            }
        | Some (_, _) ->
            do {
              DELETE_RULE Gram expr: UIDENT $x$; SELF END;
              DELETE_RULE Gram patt: UIDENT $x$; SELF END;
            }
        | None -> () ];
        defined.val := list_remove x defined.val;
      }
    with
    [ Not_found -> () ];

  (* This is a list of directories to search for INCLUDE statements. *)
  value include_dirs = ref [];

  (* Add something to the above, make sure it ends with a slash. *)
  value add_include_dir str =
    if str <> "" then
      let str =
        if String.get str ((String.length str)-1) = '/'
        then str else str ^ "/"
      in include_dirs.val := include_dirs.val @ [str]
    else ();

  value parse_include_file rule =
    let dir_ok file dir = Sys.file_exists (dir ^ file) in
    fun file ->
      let file =
        try (List.find (dir_ok file) (include_dirs.val @ ["./"])) ^ file
        with [ Not_found -> file ]
      in
      let ch = open_in file in
      let st = Stream.of_channel ch in
        Gram.parse rule (Loc.mk file) st;

  value nil_str_item =
    let _loc = Loc.ghost in <:str_item<>>;

  value rec execute_macro =
    fun
    [ SdStr i -> i
    | SdDef x eo -> do { define eo x; nil_str_item  }
    | SdUnd x -> do { undef x; nil_str_item }
    | SdITE i l1 l2 -> execute_macro_list (if is_defined i then l1 else l2)
    | SdInc f -> do { parse_include_file str_items f } ]

  and execute_macro_list = fun
  [ [] -> nil_str_item
  | [hd::tl] -> (* The evaluation order is important here *)
    let il1 = execute_macro hd in
    let il2 = execute_macro_list tl in
    let _loc = Loc.ghost in
      <:str_item< $list: [il1; il2]$ >> ] ;

  EXTEND Gram
    GLOBAL: expr patt str_item sig_item;
    str_item: FIRST
      [ [ x = macro_def -> execute_macro x ] ]
      ;
    macro_def:
      [ [ "DEFINE"; i = uident; def = opt_macro_value -> SdDef i def
        | "UNDEF"; i = uident -> SdUnd i
        | "IFDEF"; i = uident; "THEN"; st1 = smlist; st2 = else_macro_def ->
            SdITE i st1 st2
        | "IFNDEF"; i = uident; "THEN"; st2 = smlist; st1 = else_macro_def ->
            SdITE i st1 st2
        | "INCLUDE"; fname = STRING -> SdInc fname ] ]
    ;
    else_macro_def:
      [ [ "ELSE"; st = smlist; _ = endif -> st
        | _ = endif -> [] ] ]
    ;
    smlist:
      [ [ sml = LIST1 [ d = macro_def -> d | si = str_item -> SdStr si ] -> sml ] ]
    ;
    sig_item: FIRST
      [ [ "INCLUDE"; fname = STRING ->
            parse_include_file sig_items fname ] ]
    ;
    endif:
      [ [ "END" -> ()
        | "ENDIF" -> () ] ]
    ;
    opt_macro_value:
      [ [ "("; pl = LIST1 [ x = LIDENT -> x ] SEP ","; ")"; "="; e = expr -> Some (pl, e)
        | "="; e = expr -> Some ([], e)
        | -> None ] ]
    ;
    else_expr:
      [ [ "ELSE"; e = expr; _ = endif -> e
      | _ = endif -> <:expr< () >> ] ]
    ;
    expr: LEVEL "top"
      [ [ "IFDEF"; i = uident; "THEN"; e1 = expr; e2 = else_expr ->
            if is_defined i then e1 else e2
        | "IFNDEF"; i = uident; "THEN"; e1 = expr; e2 = else_expr ->
            if is_defined i then e2 else e1
        | "DEFINE"; i = LIDENT; "="; def = expr; "IN"; body = expr ->
            (new subst _loc [(i, def)])#expr body ] ]
    ;
    expr: LEVEL "simple"
      [ [ LIDENT "__FILE__" -> <:expr< $`str:Loc.file_name _loc$ >>
        | LIDENT "__LOCATION__" ->
            let (a, b, c, d, e, f, g, h) = Loc.to_tuple _loc in
            <:expr< Loc.of_tuple
                ($`str:a$, $`int:b$, $`int:c$, $`int:d$,
                 $`int:e$, $`int:f$, $`int:g$,
                 $if h then <:expr< True >> else <:expr< False >> $) >> ] ]
    ;
    patt:
      [ [ "IFDEF"; i = uident; "THEN"; p1 = patt; "ELSE"; p2 = patt; _ = endif ->
            if is_defined i then p1 else p2
        | "IFNDEF"; i = uident; "THEN"; p1 = patt; "ELSE"; p2 = patt; _ = endif ->
            if is_defined i then p2 else p1 ] ]
    ;
    uident:
      [ [ i = UIDENT -> i ] ]
    ;
  END;

  Options.add "-D" (Arg.String (define None))
    "<string> Define for IFDEF instruction.";
  Options.add "-U" (Arg.String undef)
    "<string> Undefine for IFDEF instruction.";
  Options.add "-I" (Arg.String add_include_dir)
    "<string> Add a directory to INCLUDE search path.";

end;

let module M = Register.OCamlSyntaxExtension Id Make in ();

module MakeNothing (AstFilters : Camlp4.Sig.AstFilters) = struct
  open AstFilters;
  open Ast;

  value rec map_expr =
    fun
    [ <:expr< $e$ NOTHING >>
    | <:expr< fun $ <:patt< NOTHING >> $ -> $e$ >>
      -> map_expr e
    | e -> e];

  register_str_item_filter (new Ast.c_expr map_expr)#str_item;

end;

let module M = Camlp4.Register.AstFilter Id MakeNothing in ();