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

   1 (* camlp4r *)
   2 (****************************************************************************)
   3 (*                                                                          *)
   4 (*                              Objective Caml                              *)
   5 (*                                                                          *)
   6 (*                            INRIA Rocquencourt                            *)
   7 (*                                                                          *)
   8 (*  Copyright  2007  Institut  National  de  Recherche en Informatique et   *)
   9 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
  10 (*  the terms of the GNU Library General Public License, with the special   *)
  11 (*  exception on linking described in LICENSE at the top of the Objective   *)
  12 (*  Caml source tree.                                                       *)
  13 (*                                                                          *)
  14 (****************************************************************************)
  15
  16 (* Authors:
  17  * - Nicolas Pouillard: initial version
  18  *)
  19
  20 module Make (Ast : Sig.Ast) : Sig.DynAst with module Ast = Ast = struct
  21   module Ast = Ast;
  22   type tag 'a =
  23     [ Tag_ctyp
  24     | Tag_patt
  25     | Tag_expr
  26     | Tag_module_type
  27     | Tag_sig_item
  28     | Tag_with_constr
  29     | Tag_module_expr
  30     | Tag_str_item
  31     | Tag_class_type
  32     | Tag_class_sig_item
  33     | Tag_class_expr
  34     | Tag_class_str_item
  35     | Tag_match_case
  36     | Tag_ident
  37     | Tag_binding
  38     | Tag_rec_binding
  39     | Tag_module_binding ];
  40
  41   value string_of_tag =
  42     fun
  43     [ Tag_ctyp -> "ctyp"
  44     | Tag_patt -> "patt"
  45     | Tag_expr -> "expr"
  46     | Tag_module_type -> "module_type"
  47     | Tag_sig_item -> "sig_item"
  48     | Tag_with_constr -> "with_constr"
  49     | Tag_module_expr -> "module_expr"
  50     | Tag_str_item -> "str_item"
  51     | Tag_class_type -> "class_type"
  52     | Tag_class_sig_item -> "class_sig_item"
  53     | Tag_class_expr -> "class_expr"
  54     | Tag_class_str_item -> "class_str_item"
  55     | Tag_match_case -> "match_case"
  56     | Tag_ident -> "ident"
  57     | Tag_binding -> "binding"
  58     | Tag_rec_binding -> "rec_binding"
  59     | Tag_module_binding -> "module_binding" ];
  60
  61   value ctyp_tag = Tag_ctyp;
  62   value patt_tag = Tag_patt;
  63   value expr_tag = Tag_expr;
  64   value module_type_tag = Tag_module_type;
  65   value sig_item_tag = Tag_sig_item;
  66   value with_constr_tag = Tag_with_constr;
  67   value module_expr_tag = Tag_module_expr;
  68   value str_item_tag = Tag_str_item;
  69   value class_type_tag = Tag_class_type;
  70   value class_sig_item_tag = Tag_class_sig_item;
  71   value class_expr_tag = Tag_class_expr;
  72   value class_str_item_tag = Tag_class_str_item;
  73   value match_case_tag = Tag_match_case;
  74   value ident_tag = Tag_ident;
  75   value binding_tag = Tag_binding;
  76   value rec_binding_tag = Tag_rec_binding;
  77   value module_binding_tag = Tag_module_binding;
  78
  79   type dyn;
  80   external dyn_tag : tag 'a -> tag dyn = "%identity";
  81
  82   module Pack(X : sig type t 'a; end) = struct
  83     (* These Obj.* hacks should be avoided with GADTs *)
  84     type pack = (tag dyn * Obj.t);
  85     exception Pack_error;
  86     value pack tag v = (dyn_tag tag, Obj.repr v);
  87     value unpack (tag : tag 'a) (tag', obj) =
  88       if dyn_tag tag = tag' then (Obj.obj obj : X.t 'a) else raise Pack_error;
  89     value print_tag f (tag, _) = Format.pp_print_string f (string_of_tag tag);
  90   end;
  91 end;