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