lily/ly-module.cc

   1 /*
   2   ly-module.cc -- implement guile module stuff.
   3
   4   source file of the GNU LilyPond music typesetter
   5
   6   (c) 2002--2008 Han-Wen Nienhuys <hanwen@xs4all.nl>
   7 */
   8
   9 #include "lily-guile.hh"
  10 #include "warn.hh"
  11 #include "main.hh"
  12 #include "std-string.hh"
  13 #include "protected-scm.hh"
  14
  15 #ifdef MODULE_GC_KLUDGE
  16 Protected_scm anonymous_modules = SCM_EOL;
  17 bool perform_gc_kludge;
  18 #endif
  19
  20 void
  21 clear_anonymous_modules ()
  22 {
  23 #ifdef MODULE_GC_KLUDGE
  24   for (SCM s = anonymous_modules;
  25        scm_is_pair (s);
  26        s = scm_cdr (s))
  27     {
  28       SCM module = scm_car (s);
  29       SCM closure = SCM_MODULE_EVAL_CLOSURE (module);
  30       SCM prop = scm_procedure_property (closure, ly_symbol2scm ("module"));
  31
  32       if (ly_is_module (prop))
  33         {
  34           scm_set_procedure_property_x (closure, ly_symbol2scm ("module"),
  35                                         SCM_BOOL_F);
  36         }
  37     }
  38
  39   anonymous_modules = SCM_EOL;
  40 #endif
  41 }
  42
  43 SCM
  44 ly_make_anonymous_module (bool safe)
  45 {
  46   SCM mod = SCM_EOL;
  47   if (!safe)
  48     {
  49       SCM maker = ly_lily_module_constant ("make-module");
  50
  51       SCM scm_module = ly_lily_module_constant ("the-scm-module");
  52
  53       mod = scm_call_0 (maker);
  54       scm_module_define (mod, ly_symbol2scm ("%module-public-interface"),
  55                          mod);
  56
  57       ly_use_module (mod, scm_module);
  58       ly_use_module (mod, global_lily_module);
  59     }
  60   else
  61     {
  62       SCM proc = ly_lily_module_constant ("make-safe-lilypond-module");
  63       mod = scm_call_0 (proc);
  64     }
  65
  66 #ifdef MODULE_GC_KLUDGE
  67   if (perform_gc_kludge)
  68     anonymous_modules = scm_cons (mod, anonymous_modules);
  69 #endif
  70
  71   return mod;
  72 }
  73
  74 SCM
  75 ly_use_module (SCM mod, SCM used)
  76 {
  77   SCM expr
  78     = scm_list_3 (ly_symbol2scm ("module-use!"),
  79                   mod,
  80                   scm_list_2 (ly_symbol2scm ("module-public-interface"),
  81                               used));
  82
  83   return scm_eval (expr, global_lily_module);
  84 }
  85
  86 #define FUNC_NAME __FUNCTION__
  87
  88
  89
  90 SCM
  91 ly_module_symbols (SCM mod)
  92 {
  93   SCM_VALIDATE_MODULE (1, mod);
  94
  95   SCM obarr = SCM_MODULE_OBARRAY (mod);
  96   return ly_hash_table_keys (obarr);
  97 }
  98
  99 static SCM
 100 entry_to_alist (void *closure, SCM key, SCM val, SCM result)
 101 {
 102   (void) closure;
 103   if (scm_variable_bound_p (val) == SCM_BOOL_T)
 104     return scm_cons (scm_cons (key, scm_variable_ref (val)), result);
 105   programming_error ("unbound variable in module");
 106   return result;
 107 }
 108
 109 LY_DEFINE (ly_module_2_alist, "ly:module->alist",
 110            1, 0, 0, (SCM mod),
 111            "Dump the contents of module @var{mod} as an alist.")
 112 {
 113   SCM_VALIDATE_MODULE (1, mod);
 114   SCM obarr = SCM_MODULE_OBARRAY (mod);
 115
 116   return scm_internal_hash_fold ((Hash_closure_function) & entry_to_alist, NULL, SCM_EOL, obarr);
 117 }
 118
 119 void
 120 ly_export (SCM module, SCM namelist)
 121 {
 122   static SCM export_function;
 123   if (!export_function)
 124     export_function = scm_permanent_object (scm_c_lookup ("module-export!"));
 125
 126   scm_call_2 (SCM_VARIABLE_REF (export_function), module, namelist);
 127 }
 128
 129 void
 130 ly_reexport_module (SCM mod)
 131 {
 132   ly_export (mod, ly_module_symbols (mod));
 133 }
 134
 135 #ifdef MODULE_GC_KLUDGE
 136 static SCM
 137 redefine_keyval (void *closure, SCM key, SCM val, SCM result)
 138 {
 139   (void)closure;
 140   SCM new_tab = result;
 141   scm_hashq_set_x (new_tab, key, val);
 142   return new_tab;
 143 }
 144
 145 /*
 146   UGH UGH.
 147   Kludge for older GUILE 1.6 versions.
 148 */
 149 void
 150 make_stand_in_procs_weak ()
 151 {
 152   /*
 153     Ugh, ABI breakage for 1.6.5: scm_stand_in_procs is a hashtab from
 154     1.6.5 on.
 155    */
 156   if (scm_is_pair (scm_stand_in_procs))
 157     {
 158       return;
 159     }
 160
 161   if (scm_weak_key_hash_table_p (scm_stand_in_procs) == SCM_BOOL_T)
 162     {
 163 #if (SCM_MINOR_VERSION == 7)
 164       perform_gc_kludge = false;
 165 #endif
 166       return;
 167     }
 168
 169
 170   perform_gc_kludge = true;
 171
 172
 173   SCM old_tab = scm_stand_in_procs;
 174   SCM new_tab = scm_make_weak_key_hash_table (scm_from_int (257));
 175
 176   new_tab = scm_internal_hash_fold ((Hash_closure_function) & redefine_keyval,
 177                                     NULL,
 178                                     new_tab,
 179                                     old_tab);
 180
 181   scm_stand_in_procs = new_tab;
 182 }
 183
 184 ADD_SCM_INIT_FUNC (make_stand_in_procs_weak, make_stand_in_procs_weak);
 185 #endif