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