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 */,
 101                 SCM key,
 102                 SCM val,
 103                 SCM result)
 104 {
 105   if (scm_variable_bound_p (val) == SCM_BOOL_T)
 106     return scm_cons (scm_cons (key, scm_variable_ref (val)), result);
 107   programming_error ("unbound variable in module");
 108   return result;
 109 }
 110
 111 LY_DEFINE (ly_module_2_alist, "ly:module->alist",
 112            1, 0, 0, (SCM mod),
 113            "Dump the contents of module @var{mod} as an alist.")
 114 {
 115   SCM_VALIDATE_MODULE (1, mod);
 116   SCM obarr = SCM_MODULE_OBARRAY (mod);
 117
 118   return scm_internal_hash_fold ((Hash_closure_function) & entry_to_alist, NULL, SCM_EOL, obarr);
 119 }
 120
 121 void
 122 ly_export (SCM module, SCM namelist)
 123 {
 124   static SCM export_function;
 125   if (!export_function)
 126     export_function = scm_permanent_object (scm_c_lookup ("module-export!"));
 127
 128   scm_call_2 (SCM_VARIABLE_REF (export_function), module, namelist);
 129 }
 130
 131 void
 132 ly_reexport_module (SCM mod)
 133 {
 134   ly_export (mod, ly_module_symbols (mod));
 135 }
 136
 137 #ifdef MODULE_GC_KLUDGE
 138 static SCM
 139 redefine_keyval (void * /* closure */,
 140                  SCM key,
 141                  SCM val,
 142                  SCM result)
 143 {
 144   SCM new_tab = result;
 145   scm_hashq_set_x (new_tab, key, val);
 146   return new_tab;
 147 }
 148
 149 /*
 150   UGH UGH.
 151   Kludge for older GUILE 1.6 versions.
 152 */
 153 void
 154 make_stand_in_procs_weak ()
 155 {
 156   /*
 157     Ugh, ABI breakage for 1.6.5: scm_stand_in_procs is a hashtab from
 158     1.6.5 on.
 159    */
 160   if (scm_is_pair (scm_stand_in_procs))
 161     {
 162       return;
 163     }
 164
 165   if (scm_weak_key_hash_table_p (scm_stand_in_procs) == SCM_BOOL_T)
 166     {
 167 #if (SCM_MINOR_VERSION == 7)
 168       perform_gc_kludge = false;
 169 #endif
 170       return;
 171     }
 172
 173
 174   perform_gc_kludge = true;
 175
 176
 177   SCM old_tab = scm_stand_in_procs;
 178   SCM new_tab = scm_make_weak_key_hash_table (scm_from_int (257));
 179
 180   new_tab = scm_internal_hash_fold ((Hash_closure_function) & redefine_keyval,
 181                                     NULL,
 182                                     new_tab,
 183                                     old_tab);
 184
 185   scm_stand_in_procs = new_tab;
 186 }
 187
 188 ADD_SCM_INIT_FUNC (make_stand_in_procs_weak, make_stand_in_procs_weak);
 189 #endif