diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d01beda16..5f682e8dc 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,42 @@ +2001-10-05 Dirk Herrmann + + * options.c (protected_objects, scm_init_options): The content of + protected_objects is now protected from garbage collection using + scm_gc_register_root instead of scm_permanent_object. + + (get_option_setting): New static function that computes an option + setting as it was formerly done in the function scm_options. + + (get_documented_option_setting): New static function that + returns option documentation as it was formerly done in the + function scm_options. Note that documentation C strings are no + longer precomputed into SCM objects. Instead, they are converted + into SCM strings every time get_documented_option_setting is + called. + + (change_option_setting): New static functions that modifies the + option setting as it was formerly done in the function + scm_options. The function is now exception safe, i. e. won't + cause a memory leak when interrupted. Further, only non-immediate + option values are added to the protection list. + + (scm_options): This function now has only the purpose to dispatch + to to get_option_setting, get_documented_option_setting or + change_option_setting, depending on the arguments given to + scm_options. + + (scm_init_opts): Don't convert documentation C strings into SCM + strings. Further, don't protect any object values: They _must_ + be immediate values, otherwise there is no guarantee that they + have not been collected before anyway. + + * options.[ch] (scm_t_option): Made type unsigned, name into a + constant char* and val into a scm_t_bits type. + + (scm_options, scm_init_opts): The number of options is guaranteed + to be larger or equal to zero. Thus, the type is changed to + unsigned. + 2001-10-05 Dirk Herrmann * num2integral.i.c (NUM2INTEGRAL): Eliminated some warnings about diff --git a/libguile/options.c b/libguile/options.c index 74cb820f9..e95c12a85 100644 --- a/libguile/options.c +++ b/libguile/options.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 1996, 1998, 2000, 2001 Free Software Foundation +/* Copyright (C) 1995,1996,1998,2000,2001 Free Software Foundation * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -42,10 +42,10 @@ * The author can be reached at djurfeldt@nada.kth.se * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */ - #include "libguile/_scm.h" +#include "libguile/mallocs.h" #include "libguile/strings.h" #include "libguile/options.h" @@ -116,118 +116,173 @@ SCM_SYMBOL (scm_yes_sym, "yes"); SCM_SYMBOL (scm_no_sym, "no"); -static SCM protected_objects; +static SCM protected_objects = SCM_EOL; -SCM -scm_options (SCM arg, scm_t_option options[], int n, const char *s) + +/* Return a list of the current option setting. The format of an option + * setting is described in the above documentation. */ +static SCM +get_option_setting (const scm_t_option options[], unsigned int n) { - int i, docp = (!SCM_UNBNDP (arg) && !SCM_NULLP (arg) && !SCM_CONSP (arg)); - /* Let `arg' GC protect the arguments */ - SCM new_mode = arg, ans = SCM_EOL, ls; - for (i = 0; i < n; ++i) + unsigned int i; + SCM ls = SCM_EOL; + for (i = 0; i != n; ++i) { - ls = docp ? scm_cons ((SCM) options[i].doc, SCM_EOL) : ans; switch (options[i].type) { case SCM_OPTION_BOOLEAN: - if (docp) - ls = scm_cons ((int) options[i].val - ? scm_yes_sym - : scm_no_sym, - ls); + if (options[i].val) + ls = scm_cons (SCM_PACK (options[i].name), ls); + break; + case SCM_OPTION_INTEGER: + ls = scm_cons (SCM_MAKINUM (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; +} + + +/* Return a list of sublists, where each sublist contains option name, value + * and documentation string. */ +static SCM +get_documented_option_setting (const scm_t_option options[], unsigned int n) +{ + SCM ans = SCM_EOL; + unsigned int i; + + for (i = 0; i != n; ++i) + { + SCM ls = scm_cons (scm_str2string (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_MAKINUM (options[i].val), ls); break; case SCM_OPTION_SCM: - ls = scm_cons ((SCM) options[i].val, ls); + ls = scm_cons (SCM_PACK (options[i].val), ls); } - if (!((options[i].type == SCM_OPTION_BOOLEAN) - && !docp - && ! (int) options[i].val)) - ls = scm_cons ((SCM) options[i].name, ls); - ans = docp ? scm_cons (ls, ans) : ls; - } - if (!(SCM_UNBNDP (new_mode) || docp)) - { - unsigned long *flags; - flags = (unsigned long *) scm_must_malloc (n * sizeof (unsigned long), - "mode buffer"); - for (i = 0; i < n; ++i) - if (options[i].type == SCM_OPTION_BOOLEAN) - flags[i] = 0; - else - flags[i] = (unsigned long) options[i].val; - while (SCM_NNULLP (new_mode)) - { - SCM_ASSERT (SCM_CONSP (new_mode), - new_mode, - SCM_ARG1, - s); - for (i = 0; i < n; ++i) - if (SCM_CAR (new_mode) == (SCM) options[i].name) - switch (options[i].type) - { - case SCM_OPTION_BOOLEAN: - flags[i] = 1; - goto cont; - case SCM_OPTION_INTEGER: - new_mode = SCM_CDR (new_mode); - SCM_ASSERT ( SCM_CONSP (new_mode) - && SCM_INUMP (SCM_CAR (new_mode)), - new_mode, - SCM_ARG1, - s); - flags[i] = (unsigned long) SCM_INUM (SCM_CAR (new_mode)); - goto cont; - case SCM_OPTION_SCM: - new_mode = SCM_CDR (new_mode); - flags[i] = SCM_UNPACK (SCM_CAR (new_mode)); - goto cont; - } -#ifndef SCM_RECKLESS - scm_must_free ((char *) flags); - scm_misc_error (s, "Unknown mode flag: ~S", - scm_list_1 (SCM_CAR (new_mode))); -#endif - cont: - new_mode = SCM_CDR (new_mode); - } - for (i = 0; i < n; ++i) - { - /* scm_option doesn't know if its a long or an SCM */ - if (options[i].type == SCM_OPTION_SCM) - SCM_SETCDR (protected_objects, - scm_cons (SCM_PACK(flags[i]), - scm_delq1_x (SCM_PACK(options[i].val), - SCM_CDR (protected_objects)))); - options[i].val = flags[i]; - } - scm_must_free ((char *) flags); + ls = scm_cons (SCM_PACK (options[i].name), ls); + ans = scm_cons (ls, ans); } return ans; } -void -scm_init_opts (SCM (*func) (SCM), scm_t_option options[], int n) +/* Alters options according to the given option setting 'args'. The value of + * args is known to be a list, but it is not known whether the list is a well + * formed option setting, i. e. if for every non-boolean option a value is + * given. For this reason, the function applies all changes to a copy of the + * original setting in memory. Only if 'args' was successfully processed, + * the new setting will overwrite the old one. */ +static void +change_option_setting (SCM args, scm_t_option options[], unsigned int n, const char *s) { - int i; + unsigned int i; + SCM locally_protected_args = args; + SCM malloc_obj = scm_malloc_obj (n * sizeof (scm_t_bits)); + scm_t_bits *flags = (scm_t_bits *) SCM_MALLOCDATA (malloc_obj); - for (i = 0; i < n; ++i) + for (i = 0; i != n; ++i) { - SCM name; - SCM doc; + if (options[i].type == SCM_OPTION_BOOLEAN) + flags[i] = 0; + else + flags[i] = options[i].val; + } - name = scm_str2symbol (options[i].name); - options[i].name = (char *) name; - scm_permanent_object (name); - doc = scm_take0str (options[i].doc); - options[i].doc = (char *) doc; - scm_permanent_object (doc); + while (!SCM_NULLP (args)) + { + SCM name = SCM_CAR (args); + int found = 0; + + for (i = 0; i != n && !found; ++i) + { + if (SCM_EQ_P (name, SCM_PACK (options[i].name))) + { + switch (options[i].type) + { + case SCM_OPTION_BOOLEAN: + flags[i] = 1; + break; + case SCM_OPTION_INTEGER: + args = SCM_CDR (args); + SCM_ASSERT (SCM_CONSP (args), args, SCM_ARG1, s); + SCM_ASSERT (SCM_INUMP (SCM_CAR (args)), args, SCM_ARG1, s); + flags[i] = SCM_INUM (SCM_CAR (args)); + break; + case SCM_OPTION_SCM: + args = SCM_CDR (args); + SCM_ASSERT (SCM_CONSP (args), args, SCM_ARG1, s); + flags[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); + } + + for (i = 0; i != n; ++i) + { if (options[i].type == SCM_OPTION_SCM) - SCM_SETCDR (protected_objects, - scm_cons (SCM_PACK(options[i].val), SCM_CDR (protected_objects))); + { + SCM old = SCM_PACK (options[i].val); + SCM new = SCM_PACK (flags[i]); + if (!SCM_IMP (old)) + protected_objects = scm_delq1_x (old, protected_objects); + if (!SCM_IMP (new)) + protected_objects = scm_cons (new, protected_objects); + } + options[i].val = flags[i]; + } + + scm_remember_upto_here_2 (locally_protected_args, malloc_obj); +} + + +SCM +scm_options (SCM args, scm_t_option options[], unsigned int n, const char *s) +{ + if (SCM_UNBNDP (args)) + return get_option_setting (options, n); + else if (!SCM_NULLP (args) && !SCM_CONSP (args)) + /* Dirk:FIXME:: This criterion should be improved. IMO it is better to + * demand that args is #t if documentation should be shown than to say + * that every argument except a list will print out documentation. */ + return get_documented_option_setting (options, n); + else + { + SCM old_setting; + SCM_ASSERT (!SCM_FALSEP (scm_list_p (args)), args, 1, s); + old_setting = get_option_setting (options, n); + change_option_setting (args, options, n, s); + return old_setting; + } +} + + +void +scm_init_opts (SCM (*func) (SCM), scm_t_option options[], unsigned int n) +{ + unsigned int i; + + for (i = 0; i != n; ++i) + { + SCM name = scm_str2symbol (options[i].name); + options[i].name = (char *) SCM_UNPACK (name); + scm_permanent_object (name); } func (SCM_UNDEFINED); } @@ -236,7 +291,8 @@ scm_init_opts (SCM (*func) (SCM), scm_t_option options[], int n) void scm_init_options () { - protected_objects = scm_permanent_object (scm_cons (SCM_UNDEFINED, SCM_EOL)); + scm_gc_register_root (&protected_objects); + #ifndef SCM_MAGIC_SNARFER #include "libguile/options.x" #endif diff --git a/libguile/options.h b/libguile/options.h index 98f21c464..3ab28cb69 100644 --- a/libguile/options.h +++ b/libguile/options.h @@ -55,14 +55,9 @@ typedef struct scm_t_option { - int type; - char *name; - - /* - schizophrenic use: both SCM and int - */ - unsigned long val; - /* SCM val */ + unsigned int type; + const char *name; + scm_t_bits val; char *doc; } scm_t_option; @@ -72,8 +67,8 @@ typedef struct scm_t_option #define SCM_OPTION_SCM 2 -extern SCM scm_options (SCM new_mode, scm_t_option options[], int n, const char *s); -extern void scm_init_opts (SCM (*func) (SCM), scm_t_option options[], int n); +extern SCM scm_options (SCM, scm_t_option [], unsigned int, const char*); +extern void scm_init_opts (SCM (*) (SCM), scm_t_option [], unsigned int n); extern void scm_init_options (void); #endif /* SCM_OPTIONS_H */