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 #define FUNC_NAME __FUNCTION__
  18
  19 Protected_scm anonymous_modules = SCM_EOL;
  20
  21 LY_DEFINE(ly_clear_anonymous_modules, "ly:clear-anonymous-modules",
  22           0,0,0,(),
  23           "Plug a GUILE 1.6 and 1.7 memory leak by breaking a weak reference "
  24           "pointer cycle explicitly."
  25           )
  26 {
  27 #ifdef MODULE_GC_KLUDGE
  28   for (SCM s = anonymous_modules;
  29        scm_is_pair (s);
  30        s = scm_cdr (s))
  31     {
  32       SCM module = scm_car (s);
  33       SCM closure = SCM_MODULE_EVAL_CLOSURE(module);
  34       SCM prop = scm_procedure_property (closure, ly_symbol2scm ("module"));
  35
  36       if (ly_is_module (prop))
  37         {
  38           scm_set_procedure_property_x (closure, ly_symbol2scm ("module"),
  39                                         SCM_BOOL_F);
  40         }
  41     }
  42
  43   anonymous_modules = SCM_EOL;
  44
  45 #endif
  46
  47   return SCM_UNSPECIFIED;
  48 }
  49
  50 SCM
  51 ly_make_anonymous_module (bool safe)
  52 {
  53   SCM mod = SCM_EOL;
  54   if (!safe)
  55     {
  56       SCM maker = ly_lily_module_constant ("make-module");
  57
  58       SCM scm_module = ly_lily_module_constant ("the-scm-module");
  59
  60       mod = scm_call_0 (maker);
  61       scm_module_define (mod, ly_symbol2scm ("%module-public-interface"),
  62                          mod);
  63
  64       ly_use_module (mod, scm_module);
  65       ly_use_module (mod, global_lily_module);
  66     }
  67   else
  68     {
  69       SCM proc = ly_lily_module_constant ("make-safe-lilypond-module");
  70       mod = scm_call_0 (proc);
  71     }
  72
  73 #ifdef MODULE_GC_KLUDGE
  74   anonymous_modules = scm_cons (mod, anonymous_modules);
  75 #endif
  76
  77   return mod;
  78 }
  79
  80 SCM
  81 ly_use_module (SCM mod, SCM used)
  82 {
  83   SCM expr
  84     = scm_list_3 (ly_symbol2scm ("module-use!"),
  85                   mod,
  86                   scm_list_2 (ly_symbol2scm ("module-public-interface"),
  87                               used));
  88
  89   return scm_eval (expr, global_lily_module);
  90 }
  91
  92 #define FUNC_NAME __FUNCTION__
  93
  94 static SCM
  95 module_define_closure_func (void *closure, SCM key, SCM val, SCM result)
  96 {
  97   (void) result;
  98   SCM module = (SCM) closure;
  99   if (scm_variable_bound_p (val) == SCM_BOOL_T)
 100     scm_module_define (module, key, scm_variable_ref (val));
 101   return SCM_EOL;
 102 }
 103
 104 /* Ugh signature of scm_internal_hash_fold () is inaccurate.  */
 105 typedef SCM (*Hash_cl_func) ();
 106
 107 /*
 108   If a variable in changed in SRC, we DEST doesn't see the
 109   definitions.
 110 */
 111 LY_DEFINE (ly_module_copy, "ly:module-copy",
 112            2, 0, 0, (SCM dest, SCM src),
 113            "Copy all bindings from module SRC into DEST.")
 114 {
 115   SCM_VALIDATE_MODULE (1, src);
 116   scm_internal_hash_fold ((Hash_cl_func) & module_define_closure_func,
 117                           (void *) dest,
 118                           SCM_EOL, SCM_MODULE_OBARRAY (src));
 119   return SCM_UNSPECIFIED;
 120 }
 121
 122 static SCM
 123 accumulate_symbol (void *closure, SCM key, SCM val, SCM result)
 124 {
 125   (void) closure;
 126   (void) val;
 127   return scm_cons (key, result);
 128 }
 129
 130 SCM
 131 ly_module_symbols (SCM mod)
 132 {
 133   SCM_VALIDATE_MODULE (1, mod);
 134
 135   SCM obarr = SCM_MODULE_OBARRAY (mod);
 136   return scm_internal_hash_fold ((Hash_cl_func) & accumulate_symbol,
 137                                  NULL, SCM_EOL, obarr);
 138 }
 139
 140 static SCM
 141 entry_to_alist (void *closure, SCM key, SCM val, SCM result)
 142 {
 143   (void) closure;
 144   if (scm_variable_bound_p (val) == SCM_BOOL_T)
 145     return scm_cons (scm_cons (key, scm_variable_ref (val)), result);
 146   programming_error ("unbound variable in module");
 147   return result;
 148 }
 149
 150 LY_DEFINE (ly_module2alist, "ly:module->alist",
 151            1, 0, 0, (SCM mod),
 152            "Dump the contents of  module @var{mod} as an alist.")
 153 {
 154   SCM_VALIDATE_MODULE (1, mod);
 155   SCM obarr = SCM_MODULE_OBARRAY (mod);
 156
 157   return scm_internal_hash_fold ((Hash_cl_func) & entry_to_alist, NULL, SCM_EOL, obarr);
 158 }
 159
 160 /* Lookup SYM, but don't give error when it is not defined.  */
 161 SCM
 162 ly_module_lookup (SCM module, SCM sym)
 163 {
 164 #define FUNC_NAME __FUNCTION__
 165   SCM_VALIDATE_MODULE (1, module);
 166
 167   return scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F);
 168 #undef FUNC_NAME
 169 }
 170
 171 /* Lookup SYM in a list of modules, which do not have to be related.
 172    Return the first instance. */
 173 LY_DEFINE (ly_modules_lookup, "ly:modules-lookup",
 174            2, 1, 0,
 175            (SCM modules, SCM sym, SCM def),
 176            "Lookup @var{sym} in the list @var{modules}, "
 177            "returning the first occurence.  "
 178            "If not found, return @var{default}, or @code{#f}.")
 179 {
 180   for (SCM s = modules; scm_is_pair (s); s = scm_cdr (s))
 181     {
 182       SCM mod = scm_car (s);
 183       SCM v = ly_module_lookup (mod, sym);
 184       if (SCM_VARIABLEP (v) && SCM_VARIABLE_REF (v) != SCM_UNDEFINED)
 185         return scm_variable_ref (v);
 186     }
 187
 188   if (def != SCM_UNDEFINED)
 189     return def;
 190   return SCM_BOOL_F;
 191 }
 192
 193 void
 194 ly_export (SCM module, SCM namelist)
 195 {
 196   static SCM export_function;
 197   if (!export_function)
 198     export_function = scm_permanent_object (scm_c_lookup ("module-export!"));
 199
 200   scm_call_2 (SCM_VARIABLE_REF (export_function), module, namelist);
 201 }
 202
 203 void
 204 ly_reexport_module (SCM mod)
 205 {
 206   ly_export (mod, ly_module_symbols (mod));
 207 }