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 ((Hash_closure_function) & entry_to_alist, NULL, SCM_EOL, obarr);
 130 }
 131
 132 void
 133 ly_export (SCM module, SCM namelist)
 134 {
 135   static SCM export_function;
 136   if (!export_function)
 137     export_function = scm_permanent_object (scm_c_lookup ("module-export!"));
 138
 139   scm_call_2 (SCM_VARIABLE_REF (export_function), module, namelist);
 140 }
 141
 142 void
 143 ly_reexport_module (SCM mod)
 144 {
 145   ly_export (mod, ly_module_symbols (mod));
 146 }
 147
 148 #ifdef MODULE_GC_KLUDGE
 149 static SCM
 150 redefine_keyval (void * /* closure */,
 151                  SCM key,
 152                  SCM val,
 153                  SCM result)
 154 {
 155   SCM new_tab = result;
 156   scm_hashq_set_x (new_tab, key, val);
 157   return new_tab;
 158 }
 159
 160 /*
 161   UGH UGH.
 162   Kludge for older GUILE 1.6 versions.
 163 */
 164 void
 165 make_stand_in_procs_weak ()
 166 {
 167   /*
 168     Ugh, ABI breakage for 1.6.5: scm_stand_in_procs is a hashtab from
 169     1.6.5 on.
 170    */
 171   if (scm_is_pair (scm_stand_in_procs))
 172     {
 173       return;
 174     }
 175
 176   if (scm_weak_key_hash_table_p (scm_stand_in_procs) == SCM_BOOL_T)
 177     {
 178 #if (SCM_MINOR_VERSION == 7)
 179       perform_gc_kludge = false;
 180 #endif
 181       return;
 182     }
 183
 184
 185   perform_gc_kludge = true;
 186
 187
 188   SCM old_tab = scm_stand_in_procs;
 189   SCM new_tab = scm_make_weak_key_hash_table (scm_from_int (257));
 190
 191   new_tab = scm_internal_hash_fold ((Hash_closure_function) & redefine_keyval,
 192                                     NULL,
 193                                     new_tab,
 194                                     old_tab);
 195
 196   scm_stand_in_procs = new_tab;
 197 }
 198
 199 ADD_SCM_INIT_FUNC (make_stand_in_procs_weak, make_stand_in_procs_weak);
 200 #endif