libguile/options.c

   1 /*      Copyright (C) 1995, 1996, 1998, 2000 Free Software Foundation
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program 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
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.
  41  *
  42  * The author can be reached at djurfeldt@nada.kth.se
  43  * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */
  44
  45 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  46    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  47
  48 \f
  49
  50 #include "libguile/_scm.h"
  51 #include "libguile/strings.h"
  52
  53 #include "libguile/options.h"
  54 \f
  55
  56 /* {Run-time options}
  57  *
  58  * This is the basic interface for low-level configuration of the
  59  * Guile library.  It is used for configuring the reader, evaluator,
  60  * printer and debugger.
  61  *
  62  * Motivation:
  63  *
  64  * 1. Altering option settings can have side effects.
  65  * 2. Option values can be stored in native format.
  66  *    (Important for efficiency in, e. g., the evaluator.)
  67  * 3. Doesn't use up name space.
  68  * 4. Options can be naturally grouped => ease of use.
  69  */
  70
  71 /* scm_options is the core of all options interface procedures.
  72  *
  73  * Some definitions:
  74  *
  75  * Run time options in Guile are arranged in groups.  Each group
  76  * affects a certain aspect of the behaviour of the library.
  77  *
  78  * An "options interface procedure" manages one group of options.  It
  79  * can be used to check or set options, or to get documentation for
  80  * all options of a group.  The options interface procedure is not
  81  * intended to be called directly by the user.  The user should
  82  * instead call
  83  *
  84  *   (<group>-options)
  85  *   (<group>-options 'help)
  86  *   (<group>-options 'full)
  87  *
  88  * to display current option settings (The second version also
  89  * displays documentation.  The third version also displays
  90  * information about programmer's options.), and
  91  *
  92  *   (<group>-enable  '<option-symbol>)
  93  *   (<group>-disable '<option-symbol>)
  94  *   (<group>-set! <option-symbol> <value>)
  95  *   (<group>-options <option setting>)
  96  *
  97  * to alter the state of an option  (The last version sets all
  98  * options according to <option setting>.) where <group> is the name
  99  * of the option group.
 100  *
 101  * An "option setting" represents the state of all low-level options
 102  * managed by one options interface procedure.  It is a list of
 103  * single symbols and symbols followed by a value.
 104  *
 105  * For boolean options, the presence of the symbol of that option in
 106  * the option setting indicates a true value.  If the symbol isn't a
 107  * member of the option setting this represents a false value.
 108  *
 109  * Other options are represented by a symbol followed by the value.
 110  *
 111  * If scm_options is called without arguments, the current option
 112  * setting is returned.  If the argument is an option setting, options
 113  * are altered and the old setting is returned.  If the argument isn't
 114  * a list, a list of sublists is returned, where each sublist contains
 115  * option name, value and documentation string.
 116  */
 117
 118 SCM_SYMBOL (scm_yes_sym, "yes");
 119 SCM_SYMBOL (scm_no_sym, "no");
 120
 121 static SCM protected_objects;
 122
 123 SCM
 124 scm_options (SCM arg, scm_option_t options[], int n, const char *s)
 125 {
 126   int i, docp = (!SCM_UNBNDP (arg) && !SCM_NULLP (arg) && !SCM_CONSP (arg));
 127   /* Let `arg' GC protect the arguments */
 128   SCM new_mode = arg, ans = SCM_EOL, ls;
 129   for (i = 0; i < n; ++i)
 130     {
 131       ls = docp ? scm_cons ((SCM) options[i].doc, SCM_EOL) : ans;
 132       switch (options[i].type)
 133         {
 134         case SCM_OPTION_BOOLEAN:
 135           if (docp)
 136             ls = scm_cons ((int) options[i].val
 137                            ? scm_yes_sym
 138                            : scm_no_sym,
 139                            ls);
 140           break;
 141         case SCM_OPTION_INTEGER:
 142           ls = scm_cons (SCM_MAKINUM (options[i].val), ls);
 143           break;
 144         case SCM_OPTION_SCM:
 145           ls = scm_cons ((SCM) options[i].val, ls);
 146         }
 147       if (!((options[i].type == SCM_OPTION_BOOLEAN)
 148             && !docp
 149             && ! (int) options[i].val))
 150         ls = scm_cons ((SCM) options[i].name, ls);
 151       ans = docp ? scm_cons (ls, ans) : ls;
 152     }
 153   if (!(SCM_UNBNDP (new_mode) || docp))
 154     {
 155       unsigned long *flags;
 156       flags = (unsigned long *) scm_must_malloc (n * sizeof (unsigned long),
 157                                                  "mode buffer");
 158       for (i = 0; i < n; ++i)
 159         if (options[i].type == SCM_OPTION_BOOLEAN)
 160           flags[i] = 0;
 161         else
 162           flags[i] = (unsigned long) options[i].val;
 163       while (SCM_NNULLP (new_mode))
 164         {
 165           SCM_ASSERT (SCM_CONSP (new_mode),
 166                       new_mode,
 167                       SCM_ARG1,
 168                       s);
 169           for (i = 0; i < n; ++i)
 170             if (SCM_CAR (new_mode) == (SCM) options[i].name)
 171               switch (options[i].type)
 172                 {
 173                 case SCM_OPTION_BOOLEAN:
 174                   flags[i] = 1;
 175                   goto cont;
 176                 case SCM_OPTION_INTEGER:
 177                   new_mode = SCM_CDR (new_mode);
 178                   SCM_ASSERT (   SCM_CONSP (new_mode)
 179                               && SCM_INUMP (SCM_CAR (new_mode)),
 180                               new_mode,
 181                               SCM_ARG1,
 182                               s);
 183                   flags[i] = (unsigned long) SCM_INUM (SCM_CAR (new_mode));
 184                   goto cont;
 185                 case SCM_OPTION_SCM:
 186                   new_mode = SCM_CDR (new_mode);
 187                   flags[i] = SCM_UNPACK (SCM_CAR (new_mode));
 188                   goto cont;
 189                 }
 190 #ifndef SCM_RECKLESS
 191           scm_must_free ((char *) flags);
 192           scm_misc_error (s, "Unknown mode flag: ~S",
 193                           SCM_LIST1 (SCM_CAR (new_mode)));
 194 #endif
 195         cont:
 196           new_mode = SCM_CDR (new_mode);
 197         }
 198       for (i = 0; i < n; ++i)
 199         {
 200           /* scm_option doesn't know if its a long or an SCM */
 201           if (options[i].type == SCM_OPTION_SCM)
 202             SCM_SETCDR (protected_objects,
 203                         scm_cons (SCM_PACK(flags[i]),
 204                                   scm_delq1_x (SCM_PACK(options[i].val),
 205                                                SCM_CDR (protected_objects))));
 206           options[i].val = flags[i];
 207         }
 208       scm_must_free ((char *) flags);
 209     }
 210   return ans;
 211 }
 212
 213
 214 void
 215 scm_init_opts (SCM (*func) (SCM), scm_option_t options[], int n)
 216 {
 217   int i;
 218
 219   for (i = 0; i < n; ++i)
 220     {
 221       SCM name;
 222       SCM doc;
 223
 224       name = scm_str2symbol (options[i].name);
 225       options[i].name = (char *) name;
 226       scm_permanent_object (name);
 227       doc = scm_take0str (options[i].doc);
 228       options[i].doc = (char *) doc;
 229       scm_permanent_object (doc);
 230       if (options[i].type == SCM_OPTION_SCM)
 231         SCM_SETCDR (protected_objects,
 232                     scm_cons (SCM_PACK(options[i].val), SCM_CDR (protected_objects)));
 233     }
 234   func (SCM_UNDEFINED);
 235 }
 236
 237
 238 void
 239 scm_init_options ()
 240 {
 241   protected_objects = scm_permanent_object (scm_cons (SCM_UNDEFINED, SCM_EOL));
 242 #ifndef SCM_MAGIC_SNARFER
 243 #include "libguile/options.x"
 244 #endif
 245 }
 246
 247 /*
 248   Local Variables:
 249   c-file-style: "gnu"
 250   End:
 251 */