l4/pkg/ocaml/ocaml/contrib/camlp4/Camlp4/Struct/CleanAst.ml

   1 (****************************************************************************)
   2 (*                                                                          *)
   3 (*                              Objective Caml                              *)
   4 (*                                                                          *)
   5 (*                            INRIA Rocquencourt                            *)
   6 (*                                                                          *)
   7 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
   9 (*  the terms of the GNU Library General Public License, with the special   *)
  10 (*  exception on linking described in LICENSE at the top of the Objective   *)
  11 (*  Caml source tree.                                                       *)
  12 (*                                                                          *)
  13 (****************************************************************************)
  14
  15 (* Authors:
  16  * - Nicolas Pouillard: initial version
  17  *)
  18
  19 (** This module is suppose to contain nils elimination. *)
  20 module Make (Ast : Sig.Camlp4Ast) = struct
  21
  22   class clean_ast = object
  23
  24     inherit Ast.map as super;
  25
  26     method with_constr wc =
  27       match super#with_constr wc with
  28       [ <:with_constr< $ <:with_constr<>> $ and $wc$ >> |
  29         <:with_constr< $wc$ and $ <:with_constr<>> $ >> -> wc
  30       | wc -> wc ];
  31
  32     method expr e =
  33       match super#expr e with
  34       [ <:expr< let $rec:_$ $ <:binding<>> $ in $e$ >> |
  35         <:expr< { ($e$) with $ <:rec_binding<>> $ } >> |
  36         <:expr< $ <:expr<>> $, $e$ >> |
  37         <:expr< $e$, $ <:expr<>> $ >> |
  38         <:expr< $ <:expr<>> $; $e$ >> |
  39         <:expr< $e$; $ <:expr<>> $ >> -> e
  40       | e -> e ];
  41
  42     method patt p =
  43       match super#patt p with
  44       [ <:patt< ( $p$ as $ <:patt<>> $ ) >> |
  45         <:patt< $ <:patt<>> $ | $p$ >> |
  46         <:patt< $p$ | $ <:patt<>> $ >> |
  47         <:patt< $ <:patt<>> $, $p$ >> |
  48         <:patt< $p$, $ <:patt<>> $ >> |
  49         <:patt< $ <:patt<>> $; $p$ >> |
  50         <:patt< $p$; $ <:patt<>> $ >> -> p
  51       | p -> p ];
  52
  53     method match_case mc =
  54       match super#match_case mc with
  55       [ <:match_case< $ <:match_case<>> $ | $mc$ >> |
  56         <:match_case< $mc$ | $ <:match_case<>> $ >> -> mc
  57       | mc -> mc ];
  58
  59     method binding bi =
  60       match super#binding bi with
  61       [ <:binding< $ <:binding<>> $ and $bi$ >> |
  62         <:binding< $bi$ and $ <:binding<>> $ >> -> bi
  63       | bi -> bi ];
  64
  65     method rec_binding rb =
  66       match super#rec_binding rb with
  67       [ <:rec_binding< $ <:rec_binding<>> $ ; $bi$ >> |
  68         <:rec_binding< $bi$ ; $ <:rec_binding<>> $ >> -> bi
  69       | bi -> bi ];
  70
  71     method module_binding mb =
  72       match super#module_binding mb with
  73       [ <:module_binding< $ <:module_binding<>> $ and $mb$ >> |
  74         <:module_binding< $mb$ and $ <:module_binding<>> $ >> -> mb
  75       | mb -> mb ];
  76
  77     method ctyp t =
  78       match super#ctyp t with
  79       [ <:ctyp< ! $ <:ctyp<>> $ . $t$ >> |
  80         <:ctyp< $ <:ctyp<>> $ as $t$ >> |
  81         <:ctyp< $t$ as $ <:ctyp<>> $ >> |
  82         <:ctyp< $t$ -> $ <:ctyp<>> $ >> |
  83         <:ctyp< $ <:ctyp<>> $ -> $t$ >> |
  84         <:ctyp< $ <:ctyp<>> $ | $t$ >> |
  85         <:ctyp< $t$ | $ <:ctyp<>> $ >> |
  86         <:ctyp< $t$ of $ <:ctyp<>> $ >> |
  87         <:ctyp< $ <:ctyp<>> $ and $t$ >> |
  88         <:ctyp< $t$ and $ <:ctyp<>> $ >> |
  89         <:ctyp< $t$; $ <:ctyp<>> $ >> |
  90         <:ctyp< $ <:ctyp<>> $; $t$ >> |
  91         <:ctyp< $ <:ctyp<>> $, $t$ >> |
  92         <:ctyp< $t$, $ <:ctyp<>> $ >> |
  93         <:ctyp< $t$ & $ <:ctyp<>> $ >> |
  94         <:ctyp< $ <:ctyp<>> $ & $t$ >> |
  95         <:ctyp< $ <:ctyp<>> $ * $t$ >> |
  96         <:ctyp< $t$ * $ <:ctyp<>> $ >> -> t
  97       | t -> t ];
  98
  99     method sig_item sg =
 100       match super#sig_item sg with
 101       [ <:sig_item< $ <:sig_item<>> $; $sg$ >> |
 102         <:sig_item< $sg$; $ <:sig_item<>> $ >> -> sg
 103       | <:sig_item@loc< type $ <:ctyp<>> $ >> -> <:sig_item@loc<>>
 104       | sg -> sg ];
 105
 106     method str_item st =
 107       match super#str_item st with
 108       [ <:str_item< $ <:str_item<>> $; $st$ >> |
 109         <:str_item< $st$; $ <:str_item<>> $ >> -> st
 110       | <:str_item@loc< type $ <:ctyp<>> $ >> -> <:str_item@loc<>>
 111       | <:str_item@loc< value $rec:_$ $ <:binding<>> $ >> -> <:str_item@loc<>>
 112       | st -> st ];
 113
 114     method module_type mt =
 115       match super#module_type mt with
 116       [ <:module_type< $mt$ with $ <:with_constr<>> $ >> -> mt
 117       | mt -> mt ];
 118
 119     method class_expr ce =
 120       match super#class_expr ce with
 121       [ <:class_expr< $ <:class_expr<>> $ and $ce$ >> |
 122         <:class_expr< $ce$ and $ <:class_expr<>> $ >> -> ce
 123       | ce -> ce ];
 124
 125     method class_type ct =
 126       match super#class_type ct with
 127       [ <:class_type< $ <:class_type<>> $ and $ct$ >> |
 128         <:class_type< $ct$ and $ <:class_type<>> $ >> -> ct
 129       | ct -> ct ];
 130
 131     method class_sig_item csg =
 132       match super#class_sig_item csg with
 133       [ <:class_sig_item< $ <:class_sig_item<>> $; $csg$ >> |
 134         <:class_sig_item< $csg$; $ <:class_sig_item<>> $ >> -> csg
 135       | csg -> csg ];
 136
 137     method class_str_item cst =
 138       match super#class_str_item cst with
 139       [ <:class_str_item< $ <:class_str_item<>> $; $cst$ >> |
 140         <:class_str_item< $cst$; $ <:class_str_item<>> $ >> -> cst
 141       | cst -> cst ];
 142
 143   end;
 144
 145 end;