Commit | Line | Data |
---|---|---|
86d31dfe MV |
1 | /* Copyright (C) 1995,1996,1997,1998, 2000, 2001 Free Software Foundation, Inc. |
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 | /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, | |
43 | gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ | |
44 | ||
45 | \f | |
46 | ||
47 | #include "libguile/_scm.h" | |
48 | #include "libguile/chars.h" | |
49 | #include "libguile/eval.h" | |
50 | #include "libguile/hash.h" | |
51 | #include "libguile/smob.h" | |
52 | #include "libguile/variable.h" | |
53 | #include "libguile/alist.h" | |
54 | #include "libguile/fluids.h" | |
55 | #include "libguile/strings.h" | |
56 | #include "libguile/vectors.h" | |
57 | #include "libguile/hashtab.h" | |
58 | #include "libguile/weaks.h" | |
59 | #include "libguile/modules.h" | |
60 | #include "libguile/deprecation.h" | |
61 | ||
62 | #include "libguile/validate.h" | |
63 | #include "libguile/symbols.h" | |
64 | ||
65 | #ifdef HAVE_STRING_H | |
66 | #include <string.h> | |
67 | #endif | |
68 | ||
69 | \f | |
70 | ||
71 | #if SCM_ENABLE_VCELLS | |
72 | ||
73 | /* scm_sym2ovcell | |
74 | * looks up the symbol in an arbitrary obarray. | |
75 | */ | |
76 | ||
77 | SCM | |
78 | scm_sym2ovcell_soft (SCM sym, SCM obarray) | |
79 | { | |
80 | SCM lsym, z; | |
1be6b49c | 81 | size_t hash = SCM_SYMBOL_HASH (sym) % SCM_VECTOR_LENGTH (obarray); |
86d31dfe MV |
82 | |
83 | scm_c_issue_deprecation_warning ("`scm_sym2ovcell_soft' is deprecated. " | |
84 | "Use hashtables instead."); | |
85 | ||
86 | SCM_REDEFER_INTS; | |
87 | for (lsym = SCM_VELTS (obarray)[hash]; | |
88 | SCM_NIMP (lsym); | |
89 | lsym = SCM_CDR (lsym)) | |
90 | { | |
91 | z = SCM_CAR (lsym); | |
92 | if (SCM_EQ_P (SCM_CAR (z), sym)) | |
93 | { | |
94 | SCM_REALLOW_INTS; | |
95 | return z; | |
96 | } | |
97 | } | |
98 | SCM_REALLOW_INTS; | |
99 | return SCM_BOOL_F; | |
100 | } | |
101 | ||
102 | ||
103 | SCM | |
104 | scm_sym2ovcell (SCM sym, SCM obarray) | |
105 | #define FUNC_NAME "scm_sym2ovcell" | |
106 | { | |
107 | SCM answer; | |
108 | ||
109 | scm_c_issue_deprecation_warning ("`scm_sym2ovcell' is deprecated. " | |
110 | "Use hashtables instead."); | |
111 | ||
112 | answer = scm_sym2ovcell_soft (sym, obarray); | |
113 | if (!SCM_FALSEP (answer)) | |
114 | return answer; | |
1afff620 | 115 | SCM_MISC_ERROR ("uninterned symbol: ~S", scm_list_1 (sym)); |
86d31dfe MV |
116 | return SCM_UNSPECIFIED; /* not reached */ |
117 | } | |
118 | #undef FUNC_NAME | |
119 | ||
120 | ||
121 | /* Intern a symbol whose name is the LEN characters at NAME in OBARRAY. | |
122 | ||
123 | OBARRAY should be a vector of lists, indexed by the name's hash | |
124 | value, modulo OBARRAY's length. Each list has the form | |
125 | ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the | |
126 | value associated with that symbol (in the current module? in the | |
127 | system module?) | |
128 | ||
129 | To "intern" a symbol means: if OBARRAY already contains a symbol by | |
130 | that name, return its (SYMBOL . VALUE) pair; otherwise, create a | |
131 | new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the | |
132 | appropriate list of the OBARRAY, and return the pair. | |
133 | ||
134 | If softness is non-zero, don't create a symbol if it isn't already | |
135 | in OBARRAY; instead, just return #f. | |
136 | ||
137 | If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and | |
138 | return (SYMBOL . SCM_UNDEFINED). */ | |
139 | ||
140 | ||
141 | SCM | |
1be6b49c | 142 | scm_intern_obarray_soft (const char *name,size_t len,SCM obarray,unsigned int softness) |
86d31dfe MV |
143 | { |
144 | SCM symbol = scm_mem2symbol (name, len); | |
1be6b49c ML |
145 | size_t raw_hash = SCM_SYMBOL_HASH (symbol); |
146 | size_t hash; | |
86d31dfe MV |
147 | SCM lsym; |
148 | ||
149 | scm_c_issue_deprecation_warning ("`scm_intern_obarray_soft' is deprecated. " | |
150 | "Use hashtables instead."); | |
151 | ||
152 | if (SCM_FALSEP (obarray)) | |
153 | { | |
154 | if (softness) | |
155 | return SCM_BOOL_F; | |
156 | else | |
157 | return scm_cons (symbol, SCM_UNDEFINED); | |
158 | } | |
159 | ||
160 | hash = raw_hash % SCM_VECTOR_LENGTH (obarray); | |
161 | ||
162 | for (lsym = SCM_VELTS (obarray)[hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) | |
163 | { | |
164 | SCM a = SCM_CAR (lsym); | |
165 | SCM z = SCM_CAR (a); | |
166 | if (SCM_EQ_P (z, symbol)) | |
167 | return a; | |
168 | } | |
169 | ||
170 | if (softness) | |
171 | { | |
172 | return SCM_BOOL_F; | |
173 | } | |
174 | else | |
175 | { | |
176 | SCM cell = scm_cons (symbol, SCM_UNDEFINED); | |
177 | SCM slot = SCM_VELTS (obarray) [hash]; | |
178 | ||
179 | SCM_VELTS (obarray) [hash] = scm_cons (cell, slot); | |
180 | ||
181 | return cell; | |
182 | } | |
183 | } | |
184 | ||
185 | ||
186 | SCM | |
1be6b49c | 187 | scm_intern_obarray (const char *name,size_t len,SCM obarray) |
86d31dfe MV |
188 | { |
189 | scm_c_issue_deprecation_warning ("`scm_intern_obarray' is deprecated. " | |
190 | "Use hashtables instead."); | |
191 | ||
192 | return scm_intern_obarray_soft (name, len, obarray, 0); | |
193 | } | |
194 | ||
195 | ||
196 | SCM | |
1be6b49c | 197 | scm_intern (const char *name,size_t len) |
86d31dfe MV |
198 | { |
199 | scm_c_issue_deprecation_warning ("`scm_intern' is deprecated. " | |
200 | "Use scm_c_define or scm_c_lookup instead."); | |
201 | ||
202 | { | |
203 | SCM symbol = scm_mem2symbol (name, len); | |
204 | SCM var = scm_sym2var (symbol, SCM_BOOL_F, SCM_BOOL_T); | |
205 | SCM vcell = SCM_VARVCELL (var); | |
206 | SCM_SETCAR (vcell, symbol); | |
207 | return vcell; | |
208 | } | |
209 | } | |
210 | ||
211 | ||
212 | SCM | |
213 | scm_intern0 (const char * name) | |
214 | { | |
215 | scm_c_issue_deprecation_warning ("`scm_intern0' is deprecated. " | |
216 | "Use scm_define or scm_lookup instead."); | |
217 | ||
218 | return scm_intern (name, strlen (name)); | |
219 | } | |
220 | ||
221 | /* Intern the symbol named NAME in scm_symhash, and give it the value | |
222 | VAL. NAME is null-terminated. Use the current top_level lookup | |
223 | closure to give NAME its value. | |
224 | */ | |
225 | SCM | |
226 | scm_sysintern (const char *name, SCM val) | |
227 | { | |
228 | SCM var; | |
229 | ||
230 | scm_c_issue_deprecation_warning ("`scm_sysintern' is deprecated. " | |
231 | "Use `scm_define' instead."); | |
232 | ||
233 | var = scm_c_define (name, val); | |
234 | return SCM_VARVCELL (var); | |
235 | } | |
236 | ||
237 | SCM | |
238 | scm_sysintern0 (const char *name) | |
239 | { | |
240 | SCM var; | |
241 | SCM symbol; | |
242 | ||
243 | scm_c_issue_deprecation_warning ("`scm_sysintern0' is deprecated. " | |
244 | "Use `scm_define' instead."); | |
245 | ||
246 | symbol = scm_str2symbol (name); | |
247 | var = scm_sym2var (symbol, scm_current_module_lookup_closure (), SCM_BOOL_T); | |
248 | if (var == SCM_BOOL_F) | |
249 | scm_misc_error ("sysintern0", "can't define variable", symbol); | |
250 | return SCM_VARVCELL (var); | |
251 | } | |
252 | ||
253 | /* Lookup the value of the symbol named by the nul-terminated string | |
254 | NAME in the current module. */ | |
255 | SCM | |
256 | scm_symbol_value0 (const char *name) | |
257 | { | |
258 | scm_c_issue_deprecation_warning ("`scm_symbol_value0' is deprecated. " | |
259 | "Use `scm_lookup' instead."); | |
260 | ||
261 | return scm_variable_ref (scm_c_lookup (name)); | |
262 | } | |
263 | ||
264 | SCM | |
265 | scm_sym2vcell (SCM sym, SCM thunk, SCM definep) | |
266 | { | |
267 | SCM var; | |
268 | ||
269 | scm_c_issue_deprecation_warning("`scm_sym2vcell' is deprecated. " | |
270 | "Use `scm_define' or `scm_lookup' instead."); | |
271 | ||
272 | var = scm_sym2var (sym, thunk, definep); | |
273 | if (var == SCM_BOOL_F) | |
274 | return SCM_BOOL_F; | |
275 | return SCM_VARVCELL (var); | |
276 | } | |
277 | ||
278 | SCM_DEFINE (scm_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0, | |
279 | (SCM o, SCM s, SCM softp), | |
280 | "Intern a new symbol in @var{obarray}, a symbol table, with name\n" | |
281 | "@var{string}.\n\n" | |
282 | "If @var{obarray} is @code{#f}, use the default system symbol table. If\n" | |
283 | "@var{obarray} is @code{#t}, the symbol should not be interned in any\n" | |
284 | "symbol table; merely return the pair (@var{symbol}\n" | |
285 | ". @var{#<undefined>}).\n\n" | |
286 | "The @var{soft?} argument determines whether new symbol table entries\n" | |
287 | "should be created when the specified symbol is not already present in\n" | |
288 | "@var{obarray}. If @var{soft?} is specified and is a true value, then\n" | |
289 | "new entries should not be added for symbols not already present in the\n" | |
290 | "table; instead, simply return @code{#f}.") | |
291 | #define FUNC_NAME s_scm_string_to_obarray_symbol | |
292 | { | |
293 | SCM vcell; | |
294 | SCM answer; | |
295 | int softness; | |
296 | ||
297 | SCM_VALIDATE_STRING (2, s); | |
298 | SCM_ASSERT (SCM_BOOLP (o) || SCM_VECTORP (o), o, SCM_ARG1, FUNC_NAME); | |
299 | ||
300 | scm_c_issue_deprecation_warning ("`string->obarray-symbol' is deprecated. " | |
301 | "Use hashtables instead."); | |
302 | ||
303 | softness = (!SCM_UNBNDP (softp) && !SCM_FALSEP(softp)); | |
304 | /* iron out some screwy calling conventions */ | |
305 | if (SCM_FALSEP (o)) | |
306 | { | |
307 | /* nothing interesting to do here. */ | |
308 | return scm_string_to_symbol (s); | |
309 | } | |
310 | else if (SCM_EQ_P (o, SCM_BOOL_T)) | |
311 | o = SCM_BOOL_F; | |
312 | ||
313 | vcell = scm_intern_obarray_soft (SCM_STRING_CHARS(s), | |
314 | SCM_STRING_LENGTH (s), | |
315 | o, | |
316 | softness); | |
317 | if (SCM_FALSEP (vcell)) | |
318 | return vcell; | |
319 | answer = SCM_CAR (vcell); | |
320 | return answer; | |
321 | } | |
322 | #undef FUNC_NAME | |
323 | ||
324 | SCM_DEFINE (scm_intern_symbol, "intern-symbol", 2, 0, 0, | |
325 | (SCM o, SCM s), | |
326 | "Add a new symbol to @var{obarray} with name @var{string}, bound to an\n" | |
327 | "unspecified initial value. The symbol table is not modified if a symbol\n" | |
328 | "with this name is already present.") | |
329 | #define FUNC_NAME s_scm_intern_symbol | |
330 | { | |
1be6b49c | 331 | size_t hval; |
86d31dfe MV |
332 | SCM_VALIDATE_SYMBOL (2,s); |
333 | if (SCM_FALSEP (o)) | |
334 | return SCM_UNSPECIFIED; | |
335 | ||
336 | scm_c_issue_deprecation_warning ("`intern-symbol' is deprecated. " | |
337 | "Use hashtables instead."); | |
338 | ||
339 | SCM_VALIDATE_VECTOR (1,o); | |
340 | hval = SCM_SYMBOL_HASH (s) % SCM_VECTOR_LENGTH (o); | |
341 | /* If the symbol is already interned, simply return. */ | |
342 | SCM_REDEFER_INTS; | |
343 | { | |
344 | SCM lsym; | |
345 | SCM sym; | |
346 | for (lsym = SCM_VELTS (o)[hval]; | |
347 | SCM_NIMP (lsym); | |
348 | lsym = SCM_CDR (lsym)) | |
349 | { | |
350 | sym = SCM_CAR (lsym); | |
351 | if (SCM_EQ_P (SCM_CAR (sym), s)) | |
352 | { | |
353 | SCM_REALLOW_INTS; | |
354 | return SCM_UNSPECIFIED; | |
355 | } | |
356 | } | |
357 | SCM_VELTS (o)[hval] = | |
358 | scm_acons (s, SCM_UNDEFINED, SCM_VELTS (o)[hval]); | |
359 | } | |
360 | SCM_REALLOW_INTS; | |
361 | return SCM_UNSPECIFIED; | |
362 | } | |
363 | #undef FUNC_NAME | |
364 | ||
365 | SCM_DEFINE (scm_unintern_symbol, "unintern-symbol", 2, 0, 0, | |
366 | (SCM o, SCM s), | |
367 | "Remove the symbol with name @var{string} from @var{obarray}. This\n" | |
368 | "function returns @code{#t} if the symbol was present and @code{#f}\n" | |
369 | "otherwise.") | |
370 | #define FUNC_NAME s_scm_unintern_symbol | |
371 | { | |
1be6b49c | 372 | size_t hval; |
86d31dfe MV |
373 | |
374 | scm_c_issue_deprecation_warning ("`unintern-symbol' is deprecated. " | |
375 | "Use hashtables instead."); | |
376 | ||
377 | SCM_VALIDATE_SYMBOL (2,s); | |
378 | if (SCM_FALSEP (o)) | |
379 | return SCM_BOOL_F; | |
380 | SCM_VALIDATE_VECTOR (1,o); | |
381 | hval = SCM_SYMBOL_HASH (s) % SCM_VECTOR_LENGTH (o); | |
382 | SCM_DEFER_INTS; | |
383 | { | |
384 | SCM lsym_follow; | |
385 | SCM lsym; | |
386 | SCM sym; | |
387 | for (lsym = SCM_VELTS (o)[hval], lsym_follow = SCM_BOOL_F; | |
388 | SCM_NIMP (lsym); | |
389 | lsym_follow = lsym, lsym = SCM_CDR (lsym)) | |
390 | { | |
391 | sym = SCM_CAR (lsym); | |
392 | if (SCM_EQ_P (SCM_CAR (sym), s)) | |
393 | { | |
394 | /* Found the symbol to unintern. */ | |
395 | if (SCM_FALSEP (lsym_follow)) | |
396 | SCM_VELTS(o)[hval] = lsym; | |
397 | else | |
398 | SCM_SETCDR (lsym_follow, SCM_CDR(lsym)); | |
399 | SCM_ALLOW_INTS; | |
400 | return SCM_BOOL_T; | |
401 | } | |
402 | } | |
403 | } | |
404 | SCM_ALLOW_INTS; | |
405 | return SCM_BOOL_F; | |
406 | } | |
407 | #undef FUNC_NAME | |
408 | ||
409 | SCM_DEFINE (scm_symbol_binding, "symbol-binding", 2, 0, 0, | |
410 | (SCM o, SCM s), | |
411 | "Look up in @var{obarray} the symbol whose name is @var{string}, and\n" | |
412 | "return the value to which it is bound. If @var{obarray} is @code{#f},\n" | |
413 | "use the global symbol table. If @var{string} is not interned in\n" | |
414 | "@var{obarray}, an error is signalled.") | |
415 | #define FUNC_NAME s_scm_symbol_binding | |
416 | { | |
417 | SCM vcell; | |
418 | ||
419 | scm_c_issue_deprecation_warning ("`symbol-binding' is deprecated. " | |
420 | "Use hashtables instead."); | |
421 | ||
422 | SCM_VALIDATE_SYMBOL (2,s); | |
423 | if (SCM_FALSEP (o)) | |
424 | return scm_variable_ref (scm_lookup (s)); | |
425 | SCM_VALIDATE_VECTOR (1,o); | |
426 | vcell = scm_sym2ovcell (s, o); | |
427 | return SCM_CDR(vcell); | |
428 | } | |
429 | #undef FUNC_NAME | |
430 | ||
431 | ||
432 | SCM_DEFINE (scm_symbol_interned_p, "symbol-interned?", 2, 0, 0, | |
433 | (SCM o, SCM s), | |
434 | "Return @code{#t} if @var{obarray} contains a symbol with name\n" | |
435 | "@var{string}, and @code{#f} otherwise.") | |
436 | #define FUNC_NAME s_scm_symbol_interned_p | |
437 | { | |
438 | SCM vcell; | |
439 | ||
440 | scm_c_issue_deprecation_warning ("`symbol-interned?' is deprecated. " | |
441 | "Use hashtables instead."); | |
442 | ||
443 | SCM_VALIDATE_SYMBOL (2,s); | |
444 | if (SCM_FALSEP (o)) | |
445 | { | |
446 | SCM var = scm_sym2var (s, SCM_BOOL_F, SCM_BOOL_F); | |
447 | if (var != SCM_BOOL_F) | |
448 | return SCM_BOOL_T; | |
449 | return SCM_BOOL_F; | |
450 | } | |
451 | SCM_VALIDATE_VECTOR (1,o); | |
452 | vcell = scm_sym2ovcell_soft (s, o); | |
453 | return (SCM_NIMP(vcell) | |
454 | ? SCM_BOOL_T | |
455 | : SCM_BOOL_F); | |
456 | } | |
457 | #undef FUNC_NAME | |
458 | ||
459 | ||
460 | SCM_DEFINE (scm_symbol_bound_p, "symbol-bound?", 2, 0, 0, | |
461 | (SCM o, SCM s), | |
462 | "Return @code{#t} if @var{obarray} contains a symbol with name\n" | |
463 | "@var{string} bound to a defined value. This differs from\n" | |
464 | "@var{symbol-interned?} in that the mere mention of a symbol\n" | |
465 | "usually causes it to be interned; @code{symbol-bound?}\n" | |
466 | "determines whether a symbol has been given any meaningful\n" | |
467 | "value.") | |
468 | #define FUNC_NAME s_scm_symbol_bound_p | |
469 | { | |
470 | SCM vcell; | |
471 | ||
472 | scm_c_issue_deprecation_warning ("`symbol-bound?' is deprecated. " | |
473 | "Use hashtables instead."); | |
474 | ||
475 | SCM_VALIDATE_SYMBOL (2,s); | |
476 | if (SCM_FALSEP (o)) | |
477 | { | |
478 | SCM var = scm_sym2var (s, SCM_BOOL_F, SCM_BOOL_F); | |
479 | if (SCM_DEFVARIABLEP (var)) | |
480 | return SCM_BOOL_T; | |
481 | return SCM_BOOL_F; | |
482 | } | |
483 | SCM_VALIDATE_VECTOR (1,o); | |
484 | vcell = scm_sym2ovcell_soft (s, o); | |
485 | return SCM_BOOL (SCM_NIMP (vcell) && !SCM_UNBNDP (SCM_CDR (vcell))); | |
486 | } | |
487 | #undef FUNC_NAME | |
488 | ||
489 | ||
490 | SCM_DEFINE (scm_symbol_set_x, "symbol-set!", 3, 0, 0, | |
491 | (SCM o, SCM s, SCM v), | |
492 | "Find the symbol in @var{obarray} whose name is @var{string}, and rebind\n" | |
493 | "it to @var{value}. An error is signalled if @var{string} is not present\n" | |
494 | "in @var{obarray}.") | |
495 | #define FUNC_NAME s_scm_symbol_set_x | |
496 | { | |
497 | SCM vcell; | |
498 | ||
499 | scm_c_issue_deprecation_warning ("`symbol-set!' is deprecated. " | |
500 | "Use the module system instead."); | |
501 | ||
502 | SCM_VALIDATE_SYMBOL (2,s); | |
503 | if (SCM_FALSEP (o)) | |
504 | { | |
505 | scm_define (s, v); | |
506 | return SCM_UNSPECIFIED; | |
507 | } | |
508 | SCM_VALIDATE_VECTOR (1,o); | |
509 | vcell = scm_sym2ovcell (s, o); | |
510 | SCM_SETCDR (vcell, v); | |
511 | return SCM_UNSPECIFIED; | |
512 | } | |
513 | #undef FUNC_NAME | |
514 | ||
515 | #if 0 | |
516 | ||
517 | static void | |
518 | copy_and_prune_obarray (SCM from, SCM to) | |
519 | { | |
520 | int i; | |
521 | int length = SCM_VECTOR_LENGTH (from); | |
522 | for (i = 0; i < length; ++i) | |
523 | { | |
524 | SCM head = SCM_VELTS (from)[i]; /* GC protection */ | |
525 | SCM ls = head; | |
526 | SCM res = SCM_EOL; | |
527 | SCM *lloc = &res; | |
528 | while (SCM_NIMP (ls)) | |
529 | { | |
530 | if (!SCM_UNBNDP (SCM_CDAR (ls))) | |
531 | { | |
532 | *lloc = scm_cons (SCM_CAR (ls), SCM_EOL); | |
533 | lloc = SCM_CDRLOC (*lloc); | |
534 | } | |
535 | ls = SCM_CDR (ls); | |
536 | } | |
537 | SCM_VELTS (to)[i] = res; | |
538 | } | |
539 | } | |
540 | ||
541 | ||
542 | SCM_DEFINE (scm_builtin_bindings, "builtin-bindings", 0, 0, 0, | |
543 | (), | |
544 | "Create and return a copy of the global symbol table, removing all\n" | |
545 | "unbound symbols.") | |
546 | #define FUNC_NAME s_scm_builtin_bindings | |
547 | { | |
548 | int length = SCM_VECTOR_LENGTH (scm_symhash); | |
549 | SCM obarray = scm_c_make_hash_table (length); | |
550 | ||
551 | scm_issue_deprecation_warning ("`builtin-bindings' is deprecated. " | |
552 | "Use the module system instead."); | |
553 | ||
554 | copy_and_prune_obarray (scm_symhash, obarray); | |
555 | return obarray; | |
556 | } | |
557 | #undef FUNC_NAME | |
558 | ||
559 | #endif | |
560 | ||
561 | #define MAX_PREFIX_LENGTH 30 | |
562 | ||
563 | static int gentemp_counter; | |
564 | ||
565 | SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0, | |
566 | (SCM prefix, SCM obarray), | |
567 | "Create a new symbol with a name unique in an obarray.\n" | |
568 | "The name is constructed from an optional string @var{prefix}\n" | |
569 | "and a counter value. The default prefix is @code{t}. The\n" | |
570 | "@var{obarray} is specified as a second optional argument.\n" | |
571 | "Default is the system obarray where all normal symbols are\n" | |
572 | "interned. The counter is increased by 1 at each\n" | |
573 | "call. There is no provision for resetting the counter.") | |
574 | #define FUNC_NAME s_scm_gentemp | |
575 | { | |
576 | char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN]; | |
577 | char *name = buf; | |
578 | int len, n_digits; | |
579 | ||
580 | scm_c_issue_deprecation_warning ("`gentemp' is deprecated. " | |
581 | "Use `gensym' instead."); | |
582 | ||
583 | if (SCM_UNBNDP (prefix)) | |
584 | { | |
585 | name[0] = 't'; | |
586 | len = 1; | |
587 | } | |
588 | else | |
589 | { | |
590 | SCM_VALIDATE_STRING (1, prefix); | |
591 | len = SCM_STRING_LENGTH (prefix); | |
592 | if (len > MAX_PREFIX_LENGTH) | |
593 | name = SCM_MUST_MALLOC (MAX_PREFIX_LENGTH + SCM_INTBUFLEN); | |
594 | strncpy (name, SCM_STRING_CHARS (prefix), len); | |
595 | } | |
596 | ||
597 | if (SCM_UNBNDP (obarray)) | |
598 | return scm_gensym (prefix); | |
599 | else | |
600 | SCM_ASSERT ((SCM_VECTORP (obarray) || SCM_WVECTP (obarray)), | |
601 | obarray, | |
602 | SCM_ARG2, | |
603 | FUNC_NAME); | |
604 | do | |
605 | n_digits = scm_iint2str (gentemp_counter++, 10, &name[len]); | |
606 | while (!SCM_FALSEP (scm_intern_obarray_soft (name, | |
607 | len + n_digits, | |
608 | obarray, | |
609 | 1))); | |
610 | { | |
611 | SCM vcell = scm_intern_obarray_soft (name, | |
612 | len + n_digits, | |
613 | obarray, | |
614 | 0); | |
615 | if (name != buf) | |
616 | scm_must_free (name); | |
617 | return SCM_CAR (vcell); | |
618 | } | |
619 | } | |
620 | #undef FUNC_NAME | |
621 | ||
622 | void | |
623 | scm_init_symbols_deprecated () | |
624 | { | |
625 | gentemp_counter = 0; | |
626 | #ifndef SCM_MAGIC_SNARFER | |
627 | #include "libguile/symbols-deprecated.x" | |
628 | #endif | |
629 | } | |
630 | ||
631 | #endif /* SCM_ENABLE_VCELLS */ | |
632 | ||
633 | /* | |
634 | Local Variables: | |
635 | c-file-style: "gnu" | |
636 | End: | |
637 | */ |