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
  85 static SCM
  86 accumulate_symbol (void *closure, SCM key, SCM val, SCM result)
  87 {
  88   (void) closure;
  89   (void) val;
  90   return scm_cons (key, result);
  91 }
  92
  93 SCM
  94 ly_module_symbols (SCM mod)
  95 {
  96   SCM_VALIDATE_MODULE (1, mod);
  97
  98   SCM obarr = SCM_MODULE_OBARRAY (mod);
  99   return scm_internal_hash_fold ((Hash_closure_function) & accumulate_symbol,
 100                                  NULL, SCM_EOL, obarr);
 101 }
 102
 103 static SCM
 104 entry_to_alist (void *closure, SCM key, SCM val, SCM result)
 105 {
 106   (void) closure;
 107   if (scm_variable_bound_p (val) == SCM_BOOL_T)
 108     return scm_cons (scm_cons (key, scm_variable_ref (val)), result);
 109   programming_error ("unbound variable in module");
 110   return result;
 111 }
 112
 113 LY_DEFINE (ly_module2alist, "ly:module->alist",
 114            1, 0, 0, (SCM mod),
 115            "Dump the contents of  module @var{mod} as an alist.")
 116 {
 117   SCM_VALIDATE_MODULE (1, mod);
 118   SCM obarr = SCM_MODULE_OBARRAY (mod);
 119
 120   return scm_internal_hash_fold ((Hash_closure_function) & entry_to_alist, NULL, SCM_EOL, obarr);
 121 }
 122
 123 void
 124 ly_export (SCM module, SCM namelist)
 125 {
 126   static SCM export_function;
 127   if (!export_function)
 128     export_function = scm_permanent_object (scm_c_lookup ("module-export!"));
 129
 130   scm_call_2 (SCM_VARIABLE_REF (export_function), module, namelist);
 131 }
 132
 133 void
 134 ly_reexport_module (SCM mod)
 135 {
 136   ly_export (mod, ly_module_symbols (mod));
 137 }
 138
 139
 140 #ifdef MODULE_GC_KLUDGE
 141 static SCM
 142 redefine_keyval (void *closure, SCM key, SCM val, SCM result)
 143 {
 144   (void)closure;
 145   SCM new_tab = result;
 146   scm_hashq_set_x (new_tab, key, val);
 147   return new_tab;
 148 }
 149
 150 /*
 151   UGH UGH.
 152   Kludge for older GUILE 1.6 versions.
 153 */
 154 void
 155 make_stand_in_procs_weak ()
 156 {
 157   SCM old_tab = scm_stand_in_procs;
 158   SCM new_tab = scm_make_weak_key_hash_table (scm_from_int (257));
 159
 160   new_tab = scm_internal_hash_fold ((Hash_closure_function) & redefine_keyval,
 161                                     NULL,
 162                                     new_tab,
 163                                     old_tab);
 164
 165   scm_stand_in_procs = new_tab;
 166 }
 167
 168 ADD_SCM_INIT_FUNC (make_stand_in_procs_weak, make_stand_in_procs_weak);
 169 #endif