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