lily/ly-module.cc

   1 /*
   2   This file is part of LilyPond, the GNU music typesetter.
   3
   4   Copyright (C) 2002--2010 Han-Wen Nienhuys <hanwen@xs4all.nl>
   5
   6   LilyPond is free software: you can redistribute it and/or modify
   7   it under the terms of the GNU General Public License as published by
   8   the Free Software Foundation, either version 3 of the License, or
   9   (at your option) any later version.
  10
  11   LilyPond is distributed in the hope that it will be useful,
  12   but WITHOUT ANY WARRANTY; without even the implied warranty of
  13   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14   GNU General Public License for more details.
  15
  16   You should have received a copy of the GNU General Public License
  17   along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
  18 */
  19
  20 #include "lily-guile.hh"
  21 #include "warn.hh"
  22 #include "main.hh"
  23 #include "std-string.hh"
  24 #include "protected-scm.hh"
  25
  26 #ifdef MODULE_GC_KLUDGE
  27 Protected_scm anonymous_modules = SCM_EOL;
  28 bool perform_gc_kludge;
  29 #endif
  30
  31 void
  32 clear_anonymous_modules ()
  33 {
  34 #ifdef MODULE_GC_KLUDGE
  35   for (SCM s = anonymous_modules;
  36        scm_is_pair (s);
  37        s = scm_cdr (s))
  38     {
  39       SCM module = scm_car (s);
  40       SCM closure = SCM_MODULE_EVAL_CLOSURE (module);
  41       SCM prop = scm_procedure_property (closure, ly_symbol2scm ("module"));
  42
  43       if (ly_is_module (prop))
  44         {
  45           scm_set_procedure_property_x (closure, ly_symbol2scm ("module"),
  46                                         SCM_BOOL_F);
  47         }
  48     }
  49
  50   anonymous_modules = SCM_EOL;
  51 #endif
  52 }
  53
  54 SCM
  55 ly_make_anonymous_module (bool safe)
  56 {
  57   SCM mod = SCM_EOL;
  58   if (!safe)
  59     {
  60       SCM maker = ly_lily_module_constant ("make-module");
  61
  62       SCM scm_module = ly_lily_module_constant ("the-scm-module");
  63
  64       mod = scm_call_0 (maker);
  65       scm_module_define (mod, ly_symbol2scm ("%module-public-interface"),
  66                          mod);
  67
  68       ly_use_module (mod, scm_module);
  69       ly_use_module (mod, global_lily_module);
  70     }
  71   else
  72     {
  73       SCM proc = ly_lily_module_constant ("make-safe-lilypond-module");
  74       mod = scm_call_0 (proc);
  75     }
  76
  77 #ifdef MODULE_GC_KLUDGE
  78   if (perform_gc_kludge)
  79     anonymous_modules = scm_cons (mod, anonymous_modules);
  80 #endif
  81
  82   return mod;
  83 }
  84
  85 SCM
  86 ly_use_module (SCM mod, SCM used)
  87 {
  88   SCM expr
  89     = scm_list_3 (ly_symbol2scm ("module-use!"),
  90                   mod,
  91                   scm_list_2 (ly_symbol2scm ("module-public-interface"),
  92                               used));
  93
  94   return scm_eval (expr, global_lily_module);
  95 }
  96
  97 #define FUNC_NAME __FUNCTION__
  98
  99
 100
 101 SCM
 102 ly_module_symbols (SCM mod)
 103 {
 104   SCM_VALIDATE_MODULE (1, mod);
 105
 106   SCM obarr = SCM_MODULE_OBARRAY (mod);
 107   return ly_hash_table_keys (obarr);
 108 }
 109
 110 static SCM
 111 entry_to_alist (void * /* closure */,
 112                 SCM key,
 113                 SCM val,
 114                 SCM result)
 115 {
 116   if (scm_variable_bound_p (val) == SCM_BOOL_T)
 117     return scm_cons (scm_cons (key, scm_variable_ref (val)), result);
 118   programming_error ("unbound variable in module");
 119   return result;
 120 }
 121
 122 LY_DEFINE (ly_module_2_alist, "ly:module->alist",
 123            1, 0, 0, (SCM mod),
 124            "Dump the contents of module @var{mod} as an alist.")
 125 {
 126   SCM_VALIDATE_MODULE (1, mod);
 127   SCM obarr = SCM_MODULE_OBARRAY (mod);
 128
 129   return scm_internal_hash_fold ((scm_t_hash_fold_fn) &entry_to_alist,
 130                                  NULL, SCM_EOL, obarr);
 131 }
 132
 133 void
 134 ly_export (SCM module, SCM namelist)
 135 {
 136   static SCM export_function;
 137   if (!export_function)
 138     export_function = scm_permanent_object (scm_c_lookup ("module-export!"));
 139
 140   scm_call_2 (SCM_VARIABLE_REF (export_function), module, namelist);
 141 }
 142
 143 void
 144 ly_reexport_module (SCM mod)
 145 {
 146   ly_export (mod, ly_module_symbols (mod));
 147 }
 148
 149 #ifdef MODULE_GC_KLUDGE
 150 static SCM
 151 redefine_keyval (void * /* closure */,
 152                  SCM key,
 153                  SCM val,
 154                  SCM result)
 155 {
 156   SCM new_tab = result;
 157   scm_hashq_set_x (new_tab, key, val);
 158   return new_tab;
 159 }
 160
 161 /*
 162   UGH UGH.
 163   Kludge for older GUILE 1.6 versions.
 164 */
 165 void
 166 make_stand_in_procs_weak ()
 167 {
 168   /*
 169     Ugh, ABI breakage for 1.6.5: scm_stand_in_procs is a hashtab from
 170     1.6.5 on.
 171    */
 172   if (scm_is_pair (scm_stand_in_procs))
 173     {
 174       return;
 175     }
 176
 177   if (scm_weak_key_hash_table_p (scm_stand_in_procs) == SCM_BOOL_T)
 178     {
 179 #if (SCM_MINOR_VERSION == 7)
 180       perform_gc_kludge = false;
 181 #endif
 182       return;
 183     }
 184
 185
 186   perform_gc_kludge = true;
 187
 188
 189   SCM old_tab = scm_stand_in_procs;
 190   SCM new_tab = scm_make_weak_key_hash_table (scm_from_int (257));
 191
 192   new_tab = scm_internal_hash_fold ((scm_t_hash_fold_fn) &redefine_keyval,
 193                                     NULL, new_tab, old_tab);
 194
 195   scm_stand_in_procs = new_tab;
 196 }
 197
 198 ADD_SCM_INIT_FUNC (make_stand_in_procs_weak, make_stand_in_procs_weak);
 199 #endif