123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285 |
- #ifdef HAVE_CONFIG_H
- # include <config.h>
- #endif
- #include "libguile/_scm.h"
- #include "libguile/mallocs.h"
- #include "libguile/strings.h"
- #include "libguile/options.h"
- SCM_SYMBOL (scm_yes_sym, "yes");
- SCM_SYMBOL (scm_no_sym, "no");
- static SCM
- get_option_setting (const scm_t_option options[])
- {
- unsigned int i;
- SCM ls = SCM_EOL;
- for (i = 0; options[i].name; ++i)
- {
- switch (options[i].type)
- {
- case SCM_OPTION_BOOLEAN:
- if (options[i].val)
- ls = scm_cons (SCM_PACK (options[i].name), ls);
- break;
- case SCM_OPTION_INTEGER:
- ls = scm_cons (scm_from_unsigned_integer (options[i].val), ls);
- ls = scm_cons (SCM_PACK (options[i].name), ls);
- break;
- case SCM_OPTION_SCM:
- ls = scm_cons (SCM_PACK (options[i].val), ls);
- ls = scm_cons (SCM_PACK (options[i].name), ls);
- }
- }
- return ls;
- }
- static SCM
- get_documented_option_setting (const scm_t_option options[])
- {
- SCM ans = SCM_EOL;
- unsigned int i;
- for (i = 0; options[i].name; ++i)
- {
- SCM ls = scm_cons (scm_from_utf8_string (options[i].doc), SCM_EOL);
- switch (options[i].type)
- {
- case SCM_OPTION_BOOLEAN:
- ls = scm_cons (options[i].val ? scm_yes_sym : scm_no_sym, ls);
- break;
- case SCM_OPTION_INTEGER:
- ls = scm_cons (scm_from_unsigned_integer (options[i].val), ls);
- break;
- case SCM_OPTION_SCM:
- ls = scm_cons (SCM_PACK (options[i].val), ls);
- }
- ls = scm_cons (SCM_PACK (options[i].name), ls);
- ans = scm_cons (ls, ans);
- }
- return scm_reverse_x (ans, SCM_UNDEFINED);
- }
- static int
- options_length (scm_t_option options[])
- {
- unsigned int i = 0;
- for (; options[i].name != NULL; ++i)
- ;
- return i;
- }
- static void
- change_option_setting (SCM args, scm_t_option options[], const char *s,
- int dry_run)
- {
- unsigned int i;
- scm_t_bits *new_vals;
- new_vals = scm_gc_malloc (options_length (options) * sizeof (scm_t_bits),
- "new-options");
- for (i = 0; options[i].name; ++i)
- {
- if (options[i].type == SCM_OPTION_BOOLEAN)
- new_vals[i] = 0;
- else
- new_vals[i] = options[i].val;
- }
- while (!SCM_NULL_OR_NIL_P (args))
- {
- SCM name = SCM_CAR (args);
- int found = 0;
- for (i = 0; options[i].name && !found; ++i)
- {
- if (scm_is_eq (name, SCM_PACK (options[i].name)))
- {
- switch (options[i].type)
- {
- case SCM_OPTION_BOOLEAN:
- new_vals[i] = 1;
- break;
- case SCM_OPTION_INTEGER:
- args = SCM_CDR (args);
- new_vals[i] = scm_to_size_t (scm_car (args));
- break;
- case SCM_OPTION_SCM:
- args = SCM_CDR (args);
- new_vals[i] = SCM_UNPACK (scm_car (args));
- break;
- }
- found = 1;
- }
- }
- if (!found)
- scm_misc_error (s, "Unknown option name: ~S", scm_list_1 (name));
- args = SCM_CDR (args);
- }
- if (dry_run)
- return;
-
- for (i = 0; options[i].name; ++i)
- options[i].val = new_vals[i];
- }
- SCM
- scm_options (SCM args, scm_t_option options[], const char *s)
- {
- return scm_options_try (args, options, s, 0);
- }
-
- SCM
- scm_options_try (SCM args, scm_t_option options[], const char *s,
- int dry_run)
- {
- if (SCM_UNBNDP (args))
- return get_option_setting (options);
- else if (!SCM_NULL_OR_NIL_P (args) && !scm_is_pair (args))
-
- return get_documented_option_setting (options);
- else
- {
- SCM old_setting;
- SCM_ASSERT (scm_is_true (scm_list_p (args)), args, 1, s);
- old_setting = get_option_setting (options);
- change_option_setting (args, options, s, dry_run);
- return old_setting;
- }
- }
- void
- scm_init_opts (SCM (*func) (SCM), scm_t_option options[])
- {
- unsigned int i;
- for (i = 0; options[i].name; ++i)
- {
- SCM name = scm_from_utf8_symbol (options[i].name);
- options[i].name = (char *) SCM_UNPACK (name);
- }
- func (SCM_UNDEFINED);
- }
- void
- scm_init_options ()
- {
- #include "libguile/options.x"
- }
|