1 /* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008 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
19 #ifdef HAVE_CONFIG_H
20 # include <config.h>
21 #endif
22
23 #include "libguile/_scm.h"
24 #include "libguile/mallocs.h"
25 #include "libguile/strings.h"
26 #include "libguile/lang.h"
27
28 #include "libguile/options.h"
29
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
get_option_setting(const scm_t_option options[],unsigned int n)101 get_option_setting (const scm_t_option options[], unsigned int n)
102 {
103 unsigned int i;
104 SCM ls = SCM_EOL;
105 for (i = 0; i != n; ++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
get_documented_option_setting(const scm_t_option options[],unsigned int n)129 get_documented_option_setting (const scm_t_option options[], unsigned int n)
130 {
131 SCM ans = SCM_EOL;
132 unsigned int i;
133
134 for (i = 0; i != n; ++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 ans;
152 }
153
154
155 /* Alters options according to the given option setting 'args'. The value of
156 * args is known to be a list, but it is not known whether the list is a well
157 * formed option setting, i. e. if for every non-boolean option a value is
158 * given. For this reason, the function applies all changes to a copy of the
159 * original setting in memory. Only if 'args' was successfully processed,
160 * the new setting will overwrite the old one. */
161 static void
change_option_setting(SCM args,scm_t_option options[],unsigned int n,const char * s)162 change_option_setting (SCM args, scm_t_option options[], unsigned int n, const char *s)
163 {
164 unsigned int i;
165 SCM locally_protected_args = args;
166 SCM malloc_obj = scm_malloc_obj (n * sizeof (scm_t_bits));
167 scm_t_bits *flags = (scm_t_bits *) SCM_MALLOCDATA (malloc_obj);
168
169 for (i = 0; i != n; ++i)
170 {
171 if (options[i].type == SCM_OPTION_BOOLEAN)
172 flags[i] = 0;
173 else
174 flags[i] = options[i].val;
175 }
176
177 while (!SCM_NULL_OR_NIL_P (args))
178 {
179 SCM name = SCM_CAR (args);
180 int found = 0;
181
182 for (i = 0; i != n && !found; ++i)
183 {
184 if (scm_is_eq (name, SCM_PACK (options[i].name)))
185 {
186 switch (options[i].type)
187 {
188 case SCM_OPTION_BOOLEAN:
189 flags[i] = 1;
190 break;
191 case SCM_OPTION_INTEGER:
192 args = SCM_CDR (args);
193 flags[i] = scm_to_size_t (scm_car (args));
194 break;
195 case SCM_OPTION_SCM:
196 args = SCM_CDR (args);
197 flags[i] = SCM_UNPACK (scm_car (args));
198 break;
199 }
200 found = 1;
201 }
202 }
203
204 if (!found)
205 scm_misc_error (s, "Unknown option name: ~S", scm_list_1 (name));
206
207 args = SCM_CDR (args);
208 }
209
210 for (i = 0; i != n; ++i)
211 {
212 if (options[i].type == SCM_OPTION_SCM)
213 {
214 SCM old = SCM_PACK (options[i].val);
215 SCM new = SCM_PACK (flags[i]);
216 if (!SCM_IMP (old))
217 protected_objects = scm_delq1_x (old, protected_objects);
218 if (!SCM_IMP (new))
219 protected_objects = scm_cons (new, protected_objects);
220 }
221 options[i].val = flags[i];
222 }
223
224 scm_remember_upto_here_2 (locally_protected_args, malloc_obj);
225 }
226
227
228 SCM
scm_options(SCM args,scm_t_option options[],unsigned int n,const char * s)229 scm_options (SCM args, scm_t_option options[], unsigned int n, const char *s)
230 {
231 if (SCM_UNBNDP (args))
232 return get_option_setting (options, n);
233 else if (!SCM_NULL_OR_NIL_P (args) && !scm_is_pair (args))
234 /* Dirk:FIXME:: This criterion should be improved. IMO it is better to
235 * demand that args is #t if documentation should be shown than to say
236 * that every argument except a list will print out documentation. */
237 return get_documented_option_setting (options, n);
238 else
239 {
240 SCM old_setting;
241 SCM_ASSERT (scm_is_true (scm_list_p (args)), args, 1, s);
242 old_setting = get_option_setting (options, n);
243 change_option_setting (args, options, n, s);
244 return old_setting;
245 }
246 }
247
248
249 void
scm_init_opts(SCM (* func)(SCM),scm_t_option options[],unsigned int n)250 scm_init_opts (SCM (*func) (SCM), scm_t_option options[], unsigned int n)
251 {
252 unsigned int i;
253
254 for (i = 0; i != n; ++i)
255 {
256 SCM name = scm_from_locale_symbol (options[i].name);
257 options[i].name = (char *) SCM_UNPACK (name);
258 scm_permanent_object (name);
259 }
260 func (SCM_UNDEFINED);
261 }
262
263
264 void
scm_init_options()265 scm_init_options ()
266 {
267 scm_gc_register_root (&protected_objects);
268
269 #include "libguile/options.x"
270 }
271
272 /*
273 Local Variables:
274 c-file-style: "gnu"
275 End:
276 */
277