libguile/options.c

   1 /* Copyright (C) 1995,1996,1998,2000,2001, 2006 Free Software Foundation
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public
   5  * License as published by the Free Software Foundation; either
   6  * version 2.1 of the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16  */
  17
  18 \f
  19
  20 #include "libguile/_scm.h"
  21 #include "libguile/mallocs.h"
  22 #include "libguile/strings.h"
  23 #include "libguile/lang.h"
  24
  25 #include "libguile/options.h"
  26 \f
  27
  28 /* {Run-time options}
  29  *
  30  * This is the basic interface for low-level configuration of the
  31  * Guile library.  It is used for configuring the reader, evaluator,
  32  * printer and debugger.
  33  *
  34  * Motivation:
  35  *
  36  * 1. Altering option settings can have side effects.
  37  * 2. Option values can be stored in native format.
  38  *    (Important for efficiency in, e. g., the evaluator.)
  39  * 3. Doesn't use up name space.
  40  * 4. Options can be naturally grouped => ease of use.
  41  */
  42
  43 /* scm_options is the core of all options interface procedures.
  44  *
  45  * Some definitions:
  46  *
  47  * Run time options in Guile are arranged in groups.  Each group
  48  * affects a certain aspect of the behaviour of the library.
  49  *
  50  * An "options interface procedure" manages one group of options.  It
  51  * can be used to check or set options, or to get documentation for
  52  * all options of a group.  The options interface procedure is not
  53  * intended to be called directly by the user.  The user should
  54  * instead call
  55  *
  56  *   (<group>-options)
  57  *   (<group>-options 'help)
  58  *   (<group>-options 'full)
  59  *
  60  * to display current option settings (The second version also
  61  * displays documentation.  The third version also displays
  62  * information about programmer's options.), and
  63  *
  64  *   (<group>-enable  '<option-symbol>)
  65  *   (<group>-disable '<option-symbol>)
  66  *   (<group>-set! <option-symbol> <value>)
  67  *   (<group>-options <option setting>)
  68  *
  69  * to alter the state of an option  (The last version sets all
  70  * options according to <option setting>.) where <group> is the name
  71  * of the option group.
  72  *
  73  * An "option setting" represents the state of all low-level options
  74  * managed by one options interface procedure.  It is a list of
  75  * single symbols and symbols followed by a value.
  76  *
  77  * For boolean options, the presence of the symbol of that option in
  78  * the option setting indicates a true value.  If the symbol isn't a
  79  * member of the option setting this represents a false value.
  80  *
  81  * Other options are represented by a symbol followed by the value.
  82  *
  83  * If scm_options is called without arguments, the current option
  84  * setting is returned.  If the argument is an option setting, options
  85  * are altered and the old setting is returned.  If the argument isn't
  86  * a list, a list of sublists is returned, where each sublist contains
  87  * option name, value and documentation string.
  88  */
  89
  90 SCM_SYMBOL (scm_yes_sym, "yes");
  91 SCM_SYMBOL (scm_no_sym, "no");
  92
  93 static SCM protected_objects = SCM_EOL;
  94
  95 /* Return a list of the current option setting.  The format of an
  96  * option setting is described in the above documentation.  */
  97 static SCM
  98 get_option_setting (const scm_t_option options[])
  99 {
 100   unsigned int i;
 101   SCM ls = SCM_EOL;
 102   for (i = 0; options[i].name; ++i)
 103     {
 104       switch (options[i].type)
 105         {
 106         case SCM_OPTION_BOOLEAN:
 107           if (options[i].val)
 108             ls = scm_cons (SCM_PACK (options[i].name), ls);
 109           break;
 110         case SCM_OPTION_INTEGER:
 111           ls = scm_cons (scm_from_unsigned_integer (options[i].val), ls);
 112           ls = scm_cons (SCM_PACK (options[i].name), ls);
 113           break;
 114         case SCM_OPTION_SCM:
 115           ls = scm_cons (SCM_PACK (options[i].val), ls);
 116           ls = scm_cons (SCM_PACK (options[i].name), ls);
 117         }
 118     }
 119   return ls;
 120 }
 121
 122
 123 /* Return a list of sublists, where each sublist contains option name, value
 124  * and documentation string.  */
 125 static SCM
 126 get_documented_option_setting (const scm_t_option options[])
 127 {
 128   SCM ans = SCM_EOL;
 129   unsigned int i;
 130
 131   for (i = 0; options[i].name; ++i)
 132     {
 133       SCM ls = scm_cons (scm_from_locale_string (options[i].doc), SCM_EOL);
 134       switch (options[i].type)
 135         {
 136         case SCM_OPTION_BOOLEAN:
 137           ls = scm_cons (options[i].val ? scm_yes_sym : scm_no_sym, ls);
 138           break;
 139         case SCM_OPTION_INTEGER:
 140           ls = scm_cons (scm_from_unsigned_integer (options[i].val), ls);
 141           break;
 142         case SCM_OPTION_SCM:
 143           ls = scm_cons (SCM_PACK (options[i].val), ls);
 144         }
 145       ls = scm_cons (SCM_PACK (options[i].name), ls);
 146       ans = scm_cons (ls, ans);
 147     }
 148   return ans;
 149 }
 150
 151
 152 static int
 153 options_length (scm_t_option options[])
 154 {
 155   unsigned int i = 0;
 156   for (; options[i].name != NULL; ++i)
 157     ;
 158
 159   return i;
 160 }
 161
 162 /* Alters options according to the given option setting 'args'.  The value of
 163  * args is known to be a list, but it is not known whether the list is a well
 164  * formed option setting, i. e. if for every non-boolean option a value is
 165  * given.  For this reason, the function applies all changes to a copy of the
 166  * original setting in memory.  Only if 'args' was successfully processed,
 167  * the new setting will overwrite the old one.
 168  *
 169  * If DRY_RUN is set, don't change anything. This is useful for trying out an option
 170  * before entering a critical section.
 171  */
 172 static void
 173 change_option_setting (SCM args, scm_t_option options[], const char *s,
 174                        int dry_run)
 175 {
 176   unsigned int i;
 177   SCM locally_protected_args = args;
 178   SCM malloc_obj = scm_malloc_obj (options_length (options) * sizeof (scm_t_bits));
 179   scm_t_bits *flags = (scm_t_bits *) SCM_MALLOCDATA (malloc_obj);
 180
 181   for (i = 0; options[i].name; ++i)
 182     {
 183       if (options[i].type == SCM_OPTION_BOOLEAN)
 184         flags[i] = 0;
 185       else
 186         flags[i] = options[i].val;
 187     }
 188
 189   while (!SCM_NULL_OR_NIL_P (args))
 190     {
 191       SCM name = SCM_CAR (args);
 192       int found = 0;
 193
 194       for (i = 0; options[i].name && !found; ++i)
 195         {
 196           if (scm_is_eq (name, SCM_PACK (options[i].name)))
 197             {
 198               switch (options[i].type)
 199                 {
 200                 case SCM_OPTION_BOOLEAN:
 201                   flags[i] = 1;
 202                   break;
 203                 case SCM_OPTION_INTEGER:
 204                   args = SCM_CDR (args);
 205                   flags[i] = scm_to_size_t (scm_car (args));
 206                   break;
 207                 case SCM_OPTION_SCM:
 208                   args = SCM_CDR (args);
 209                   flags[i] = SCM_UNPACK (scm_car (args));
 210                   break;
 211                 }
 212               found = 1;
 213             }
 214         }
 215
 216       if (!found)
 217         scm_misc_error (s, "Unknown option name: ~S", scm_list_1 (name));
 218
 219       args = SCM_CDR (args);
 220     }
 221
 222   if (dry_run)
 223     return;
 224
 225   for (i = 0; options[i].name; ++i)
 226     {
 227       if (options[i].type == SCM_OPTION_SCM)
 228         {
 229           SCM old = SCM_PACK (options[i].val);
 230           SCM new = SCM_PACK (flags[i]);
 231           if (!SCM_IMP (old))
 232             protected_objects = scm_delq1_x (old, protected_objects);
 233           if (!SCM_IMP (new))
 234             protected_objects = scm_cons (new, protected_objects);
 235         }
 236       options[i].val = flags[i];
 237     }
 238
 239   scm_remember_upto_here_2 (locally_protected_args, malloc_obj);
 240 }
 241
 242
 243 SCM
 244 scm_options (SCM args, scm_t_option options[], const char *s)
 245 {
 246   return scm_options_try (args, options, s, 0);
 247 }
 248
 249 SCM
 250 scm_options_try (SCM args, scm_t_option options[], const char *s,
 251                  int dry_run)
 252 {
 253   if (SCM_UNBNDP (args))
 254     return get_option_setting (options);
 255   else if (!SCM_NULL_OR_NIL_P (args) && !scm_is_pair (args))
 256     /* Dirk:FIXME:: This criterion should be improved.  IMO it is better to
 257      * demand that args is #t if documentation should be shown than to say
 258      * that every argument except a list will print out documentation.  */
 259     return get_documented_option_setting (options);
 260   else
 261     {
 262       SCM old_setting;
 263       SCM_ASSERT (scm_is_true (scm_list_p (args)), args, 1, s);
 264       old_setting = get_option_setting (options);
 265       change_option_setting (args, options, s, dry_run);
 266       return old_setting;
 267     }
 268 }
 269
 270
 271 void
 272 scm_init_opts (SCM (*func) (SCM), scm_t_option options[])
 273 {
 274   unsigned int i;
 275
 276   for (i = 0; options[i].name; ++i)
 277     {
 278       SCM name = scm_from_locale_symbol (options[i].name);
 279       options[i].name = (char *) SCM_UNPACK (name);
 280       scm_permanent_object (name);
 281     }
 282   func (SCM_UNDEFINED);
 283 }
 284
 285
 286 void
 287 scm_init_options ()
 288 {
 289   scm_gc_register_root (&protected_objects);
 290
 291 #include "libguile/options.x"
 292 }
 293
 294 /*
 295   Local Variables:
 296   c-file-style: "gnu"
 297   End:
 298 */