libguile/options.c

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