| 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 | */ |