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