X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=lily%2Fly-module.cc;h=621b65afe01b3ee11b9e3b93aa66d3649f3be915;hb=d9fcd3db46970a4afbc4e073abb2156ecc865981;hp=a9e3775a10b4e783f077f30d1f115b26d9a7088d;hpb=2536405e9584f63d559653183971c0fec57ba037;p=lilypond.git diff --git a/lily/ly-module.cc b/lily/ly-module.cc index a9e3775a10..621b65afe0 100644 --- a/lily/ly-module.cc +++ b/lily/ly-module.cc @@ -1,25 +1,54 @@ /* - ly-module.cc -- implement guile module stuff. + This file is part of LilyPond, the GNU music typesetter. - source file of the GNU LilyPond music typesetter + Copyright (C) 2002--2009 Han-Wen Nienhuys - (c) 2002--2004 Han-Wen Nienhuys + LilyPond is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + LilyPond is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with LilyPond. If not, see . */ -#include "main.hh" -#include "string.hh" #include "lily-guile.hh" -#include "ly-module.hh" +#include "warn.hh" +#include "main.hh" +#include "std-string.hh" #include "protected-scm.hh" -#define FUNC_NAME __FUNCTION__ - -static int module_count; +#ifdef MODULE_GC_KLUDGE +Protected_scm anonymous_modules = SCM_EOL; +bool perform_gc_kludge; +#endif void -ly_init_anonymous_module (void *data) +clear_anonymous_modules () { - (void) data; +#ifdef MODULE_GC_KLUDGE + for (SCM s = anonymous_modules; + scm_is_pair (s); + s = scm_cdr (s)) + { + SCM module = scm_car (s); + SCM closure = SCM_MODULE_EVAL_CLOSURE (module); + SCM prop = scm_procedure_property (closure, ly_symbol2scm ("module")); + + if (ly_is_module (prop)) + { + scm_set_procedure_property_x (closure, ly_symbol2scm ("module"), + SCM_BOOL_F); + } + } + + anonymous_modules = SCM_EOL; +#endif } SCM @@ -28,15 +57,28 @@ ly_make_anonymous_module (bool safe) SCM mod = SCM_EOL; if (!safe) { - String s = "*anonymous-ly-" + to_string (module_count++) + "*"; - mod = scm_c_define_module (s.to_str0 (), ly_init_anonymous_module, 0); + SCM maker = ly_lily_module_constant ("make-module"); + + SCM scm_module = ly_lily_module_constant ("the-scm-module"); + + mod = scm_call_0 (maker); + scm_module_define (mod, ly_symbol2scm ("%module-public-interface"), + mod); + + ly_use_module (mod, scm_module); ly_use_module (mod, global_lily_module); } else { - SCM proc = ly_scheme_function ("make-safe-lilypond-module"); + SCM proc = ly_lily_module_constant ("make-safe-lilypond-module"); mod = scm_call_0 (proc); } + +#ifdef MODULE_GC_KLUDGE + if (perform_gc_kludge) + anonymous_modules = scm_cons (mod, anonymous_modules); +#endif + return mod; } @@ -48,109 +90,43 @@ ly_use_module (SCM mod, SCM used) mod, scm_list_2 (ly_symbol2scm ("module-public-interface"), used)); - + return scm_eval (expr, global_lily_module); } #define FUNC_NAME __FUNCTION__ -static SCM -ly_module_define (void *closure, SCM key, SCM val, SCM result) -{ - (void) result; - SCM module = (SCM) closure; - if (scm_variable_bound_p (val) == SCM_BOOL_T) - scm_module_define (module, key, scm_variable_ref (val)); - return SCM_EOL; -} - -/* Ugh signature of scm_internal_hash_fold () is inaccurate. */ -typedef SCM (*Hash_cl_func)(); - -/* - Check me. This is NOT an actual import. It just copies the - definitions. - - If a variable in changed in SRC, we DEST doesn't see the - definitions. - */ -LY_DEFINE (ly_import_module, "ly:import-module", - 2, 0, 0, (SCM dest, SCM src), - "Import all bindings from module SRC into DEST.") -{ - SCM_VALIDATE_MODULE (1, src); - scm_internal_hash_fold ((Hash_cl_func) &ly_module_define, (void*) dest, - SCM_EOL, SCM_MODULE_OBARRAY (src)); - return SCM_UNSPECIFIED; -} -static SCM -accumulate_symbol (void *closure, SCM key, SCM val, SCM result) -{ - (void) closure; - (void) val; - return scm_cons (key, result); -} SCM ly_module_symbols (SCM mod) { SCM_VALIDATE_MODULE (1, mod); - - SCM obarr= SCM_MODULE_OBARRAY (mod); - return scm_internal_hash_fold ((Hash_cl_func) &accumulate_symbol, - NULL, SCM_EOL, obarr); + + SCM obarr = SCM_MODULE_OBARRAY (mod); + return ly_hash_table_keys (obarr); } static SCM -entry_to_alist (void *closure, SCM key, SCM val, SCM result) +entry_to_alist (void * /* closure */, + SCM key, + SCM val, + SCM result) { - (void) closure; - return scm_cons (scm_cons (key, scm_variable_ref (val)), result); + if (scm_variable_bound_p (val) == SCM_BOOL_T) + return scm_cons (scm_cons (key, scm_variable_ref (val)), result); + programming_error ("unbound variable in module"); + return result; } -LY_DEFINE (ly_module2alist, "ly:module->alist", +LY_DEFINE (ly_module_2_alist, "ly:module->alist", 1, 0, 0, (SCM mod), - "Dump the contents of module @var{mod} as an alist.") + "Dump the contents of module @var{mod} as an alist.") { SCM_VALIDATE_MODULE (1, mod); - SCM obarr= SCM_MODULE_OBARRAY (mod); - - return scm_internal_hash_fold ((Hash_cl_func) &entry_to_alist, NULL, SCM_EOL, obarr); -} + SCM obarr = SCM_MODULE_OBARRAY (mod); -/* Lookup SYM, but don't give error when it is not defined. */ -SCM -ly_module_lookup (SCM module, SCM sym) -{ -#define FUNC_NAME __FUNCTION__ - SCM_VALIDATE_MODULE (1, module); - - return scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F); -#undef FUNC_NAME -} - -/* Lookup SYM in a list of modules, which do not have to be related. - Return the first instance. */ -LY_DEFINE (ly_modules_lookup, "ly:modules-lookup", - 2, 1, 0, - (SCM modules, SCM sym, SCM def), - "Lookup @var{sym} in the list @var{modules}, " - "returning the first occurence. " - "If not found, return @var{default}, or @code{#f}.") -{ - for (SCM s = modules; scm_is_pair (s); s = ly_cdr (s)) - { - SCM mod = ly_car (s); - SCM v = scm_sym2var (sym, scm_module_lookup_closure (mod), - SCM_UNDEFINED); - if (SCM_VARIABLEP(v) && SCM_VARIABLE_REF(v) != SCM_UNDEFINED) - return SCM_VARIABLE_REF(v); - } - - if (def != SCM_UNDEFINED) - return def; - return SCM_BOOL_F; + return scm_internal_hash_fold ((Hash_closure_function) & entry_to_alist, NULL, SCM_EOL, obarr); } void @@ -159,7 +135,7 @@ ly_export (SCM module, SCM namelist) static SCM export_function; if (!export_function) export_function = scm_permanent_object (scm_c_lookup ("module-export!")); - + scm_call_2 (SCM_VARIABLE_REF (export_function), module, namelist); } @@ -168,3 +144,57 @@ ly_reexport_module (SCM mod) { ly_export (mod, ly_module_symbols (mod)); } + +#ifdef MODULE_GC_KLUDGE +static SCM +redefine_keyval (void * /* closure */, + SCM key, + SCM val, + SCM result) +{ + SCM new_tab = result; + scm_hashq_set_x (new_tab, key, val); + return new_tab; +} + +/* + UGH UGH. + Kludge for older GUILE 1.6 versions. +*/ +void +make_stand_in_procs_weak () +{ + /* + Ugh, ABI breakage for 1.6.5: scm_stand_in_procs is a hashtab from + 1.6.5 on. + */ + if (scm_is_pair (scm_stand_in_procs)) + { + return; + } + + if (scm_weak_key_hash_table_p (scm_stand_in_procs) == SCM_BOOL_T) + { +#if (SCM_MINOR_VERSION == 7) + perform_gc_kludge = false; +#endif + return; + } + + + perform_gc_kludge = true; + + + SCM old_tab = scm_stand_in_procs; + SCM new_tab = scm_make_weak_key_hash_table (scm_from_int (257)); + + new_tab = scm_internal_hash_fold ((Hash_closure_function) & redefine_keyval, + NULL, + new_tab, + old_tab); + + scm_stand_in_procs = new_tab; +} + +ADD_SCM_INIT_FUNC (make_stand_in_procs_weak, make_stand_in_procs_weak); +#endif