Commit | Line | Data |
---|---|---|
bccb33a9 | 1 | /* Copyright (C) 1995,1996,1997,1998, 2000 Free Software Foundation, Inc. |
0f2d19dd JB |
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 | |
82892bed JB |
15 | * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
16 | * Boston, MA 02111-1307 USA | |
0f2d19dd JB |
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. | |
82892bed | 40 | * If you do not wish that, delete this exception notice. */ |
1bbd0b84 GB |
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 | ||
0f2d19dd JB |
45 | \f |
46 | ||
47 | #include <stdio.h> | |
a0599745 MD |
48 | #include "libguile/_scm.h" |
49 | #include "libguile/chars.h" | |
50 | #include "libguile/eval.h" | |
fb43bf74 | 51 | #include "libguile/smob.h" |
a0599745 MD |
52 | #include "libguile/variable.h" |
53 | #include "libguile/alist.h" | |
7e73eaee | 54 | #include "libguile/fluids.h" |
a0599745 MD |
55 | #include "libguile/strings.h" |
56 | #include "libguile/vectors.h" | |
57 | #include "libguile/weaks.h" | |
eb8db440 | 58 | #include "libguile/modules.h" |
a0599745 MD |
59 | |
60 | #include "libguile/validate.h" | |
61 | #include "libguile/symbols.h" | |
0f2d19dd | 62 | |
95b88819 GH |
63 | #ifdef HAVE_STRING_H |
64 | #include <string.h> | |
65 | #endif | |
66 | ||
0f2d19dd JB |
67 | \f |
68 | ||
28b06554 DH |
69 | static char * |
70 | duplicate_string (const char * src, unsigned long length) | |
71 | { | |
72 | char * dst = scm_must_malloc (length + 1, "duplicate_string"); | |
1e1384f0 MD |
73 | memcpy (dst, src, length); |
74 | dst[length] = 0; | |
28b06554 DH |
75 | return dst; |
76 | } | |
77 | ||
78 | \f | |
0f2d19dd JB |
79 | |
80 | /* {Symbols} | |
81 | */ | |
82 | ||
1cc91f1b | 83 | |
0f2d19dd | 84 | unsigned long |
28b06554 | 85 | scm_string_hash (const unsigned char *str, scm_sizet len) |
0f2d19dd JB |
86 | { |
87 | if (len > 5) | |
88 | { | |
89 | scm_sizet i = 5; | |
28b06554 | 90 | unsigned long h = 264; |
0f2d19dd | 91 | while (i--) |
28b06554 | 92 | h = (h << 8) + ((unsigned) (scm_downcase (str[h % len]))); |
0f2d19dd JB |
93 | return h; |
94 | } | |
95 | else | |
96 | { | |
97 | scm_sizet i = len; | |
98 | unsigned long h = 0; | |
99 | while (i) | |
28b06554 | 100 | h = (h << 8) + ((unsigned) (scm_downcase (str[--i]))); |
0f2d19dd JB |
101 | return h; |
102 | } | |
103 | } | |
104 | ||
28b06554 | 105 | |
0f2d19dd JB |
106 | /* scm_sym2vcell |
107 | * looks up the symbol in the symhash table. | |
108 | */ | |
1cc91f1b | 109 | |
0f2d19dd | 110 | SCM |
bccb33a9 | 111 | scm_sym2vcell (SCM sym, SCM thunk, SCM definep) |
0f2d19dd | 112 | { |
bccb33a9 | 113 | if (SCM_NIMP (thunk)) |
0f2d19dd | 114 | { |
bccb33a9 MD |
115 | SCM var; |
116 | ||
fb43bf74 | 117 | if (SCM_EVAL_CLOSURE_P (thunk)) |
bccb33a9 | 118 | /* Bypass evaluator in the standard case. */ |
fb43bf74 | 119 | var = scm_eval_closure_lookup (thunk, sym, definep); |
bccb33a9 MD |
120 | else |
121 | var = scm_apply (thunk, sym, scm_cons (definep, scm_listofnull)); | |
0f2d19dd | 122 | |
bc66755e | 123 | if (SCM_FALSEP (var)) |
0f2d19dd | 124 | return SCM_BOOL_F; |
93d40df2 DH |
125 | else if (SCM_VARIABLEP (var)) |
126 | return SCM_VARVCELL (var); | |
0f2d19dd | 127 | else |
38ae064c | 128 | return scm_wta (sym, "strangely interned symbol? ", ""); |
0f2d19dd JB |
129 | } |
130 | else | |
131 | { | |
132 | SCM lsym; | |
133 | SCM * lsymp; | |
93d40df2 DH |
134 | scm_sizet hash1; |
135 | scm_sizet hash2; | |
0f2d19dd JB |
136 | |
137 | SCM_DEFER_INTS; | |
93d40df2 DH |
138 | hash1 = SCM_SYMBOL_HASH (sym) % SCM_VECTOR_LENGTH (scm_symhash); |
139 | for (lsym = SCM_VELTS (scm_symhash)[hash1]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) | |
0f2d19dd | 140 | { |
93d40df2 | 141 | SCM z = SCM_CAR (lsym); |
bc66755e | 142 | if (SCM_EQ_P (SCM_CAR (z), sym)) |
0f2d19dd JB |
143 | { |
144 | SCM_ALLOW_INTS; | |
145 | return z; | |
146 | } | |
147 | } | |
148 | ||
93d40df2 DH |
149 | hash2 = SCM_SYMBOL_HASH (sym) % SCM_VECTOR_LENGTH (scm_weak_symhash); |
150 | for (lsym = *(lsymp = &SCM_VELTS (scm_weak_symhash)[hash2]); | |
0f2d19dd | 151 | SCM_NIMP (lsym); |
25d8012c | 152 | lsym = *(lsymp = SCM_CDRLOC (lsym))) |
0f2d19dd | 153 | { |
93d40df2 | 154 | SCM z = SCM_CAR (lsym); |
bc66755e | 155 | if (SCM_EQ_P (SCM_CAR (z), sym)) |
0f2d19dd | 156 | { |
5aab5d96 | 157 | if (SCM_NFALSEP (definep)) |
0f2d19dd | 158 | { |
49bc24fe | 159 | /* Move handle from scm_weak_symhash to scm_symhash. */ |
0f2d19dd | 160 | *lsymp = SCM_CDR (lsym); |
93d40df2 DH |
161 | SCM_SETCDR (lsym, SCM_VELTS(scm_symhash)[hash1]); |
162 | SCM_VELTS(scm_symhash)[hash1] = lsym; | |
0f2d19dd JB |
163 | } |
164 | SCM_ALLOW_INTS; | |
165 | return z; | |
166 | } | |
167 | } | |
168 | SCM_ALLOW_INTS; | |
169 | return scm_wta (sym, "uninterned symbol? ", ""); | |
170 | } | |
171 | } | |
172 | ||
173 | /* scm_sym2ovcell | |
49bc24fe | 174 | * looks up the symbol in an arbitrary obarray. |
0f2d19dd | 175 | */ |
1cc91f1b | 176 | |
0f2d19dd | 177 | SCM |
1bbd0b84 | 178 | scm_sym2ovcell_soft (SCM sym, SCM obarray) |
0f2d19dd JB |
179 | { |
180 | SCM lsym, z; | |
0f87853a | 181 | scm_sizet hash = SCM_SYMBOL_HASH (sym) % SCM_VECTOR_LENGTH (obarray); |
0f2d19dd | 182 | SCM_REDEFER_INTS; |
28b06554 | 183 | for (lsym = SCM_VELTS (obarray)[hash]; |
0f2d19dd JB |
184 | SCM_NIMP (lsym); |
185 | lsym = SCM_CDR (lsym)) | |
186 | { | |
187 | z = SCM_CAR (lsym); | |
bc66755e | 188 | if (SCM_EQ_P (SCM_CAR (z), sym)) |
0f2d19dd JB |
189 | { |
190 | SCM_REALLOW_INTS; | |
191 | return z; | |
192 | } | |
193 | } | |
194 | SCM_REALLOW_INTS; | |
195 | return SCM_BOOL_F; | |
196 | } | |
197 | ||
1cc91f1b | 198 | |
0f2d19dd | 199 | SCM |
1bbd0b84 | 200 | scm_sym2ovcell (SCM sym, SCM obarray) |
0f2d19dd JB |
201 | { |
202 | SCM answer; | |
203 | answer = scm_sym2ovcell_soft (sym, obarray); | |
bc66755e | 204 | if (!SCM_FALSEP (answer)) |
0f2d19dd JB |
205 | return answer; |
206 | scm_wta (sym, "uninterned symbol? ", ""); | |
207 | return SCM_UNSPECIFIED; /* not reached */ | |
208 | } | |
209 | ||
8ce94504 JB |
210 | /* Intern a symbol whose name is the LEN characters at NAME in OBARRAY. |
211 | ||
212 | OBARRAY should be a vector of lists, indexed by the name's hash | |
213 | value, modulo OBARRAY's length. Each list has the form | |
214 | ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the | |
215 | value associated with that symbol (in the current module? in the | |
216 | system module?) | |
217 | ||
218 | To "intern" a symbol means: if OBARRAY already contains a symbol by | |
219 | that name, return its (SYMBOL . VALUE) pair; otherwise, create a | |
220 | new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the | |
221 | appropriate list of the OBARRAY, and return the pair. | |
222 | ||
223 | If softness is non-zero, don't create a symbol if it isn't already | |
224 | in OBARRAY; instead, just return #f. | |
225 | ||
226 | If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and | |
227 | return (SYMBOL . SCM_UNDEFINED). | |
228 | ||
229 | If OBARRAY is scm_symhash, and that doesn't contain the symbol, | |
230 | check scm_weak_symhash instead. */ | |
231 | ||
1cc91f1b | 232 | |
0f2d19dd | 233 | SCM |
28b06554 | 234 | scm_intern_obarray_soft (const char *name,scm_sizet len,SCM obarray,unsigned int softness) |
0f2d19dd | 235 | { |
28b06554 DH |
236 | scm_sizet raw_hash = scm_string_hash ((unsigned char *) name, len); |
237 | scm_sizet hash; | |
0f2d19dd | 238 | SCM lsym; |
0f2d19dd JB |
239 | |
240 | SCM_REDEFER_INTS; | |
241 | ||
bc66755e | 242 | if (SCM_FALSEP (obarray)) |
0f2d19dd | 243 | { |
28b06554 | 244 | hash = raw_hash % 1019; |
0f2d19dd JB |
245 | goto uninterned_symbol; |
246 | } | |
247 | ||
9fd38a3d | 248 | hash = raw_hash % SCM_VECTOR_LENGTH (obarray); |
0f2d19dd JB |
249 | |
250 | retry_new_obarray: | |
28b06554 | 251 | for (lsym = SCM_VELTS (obarray)[hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) |
0f2d19dd | 252 | { |
28b06554 DH |
253 | scm_sizet i; |
254 | SCM a = SCM_CAR (lsym); | |
255 | SCM z = SCM_CAR (a); | |
e51fe79c | 256 | char *tmp = SCM_SYMBOL_CHARS (z); |
0f87853a DH |
257 | if (SCM_SYMBOL_HASH (z) != raw_hash) |
258 | goto trynext; | |
9fd38a3d | 259 | if (SCM_SYMBOL_LENGTH (z) != len) |
0f2d19dd JB |
260 | goto trynext; |
261 | for (i = len; i--;) | |
e51fe79c | 262 | if (name[i] != tmp[i]) |
0f2d19dd JB |
263 | goto trynext; |
264 | { | |
0f2d19dd JB |
265 | SCM_REALLOW_INTS; |
266 | return a; | |
267 | } | |
268 | trynext:; | |
269 | } | |
270 | ||
bc66755e | 271 | if (SCM_EQ_P (obarray, scm_symhash)) |
0f2d19dd JB |
272 | { |
273 | obarray = scm_weak_symhash; | |
274 | goto retry_new_obarray; | |
275 | } | |
276 | ||
277 | uninterned_symbol: | |
278 | if (softness) | |
279 | { | |
280 | SCM_REALLOW_INTS; | |
281 | return SCM_BOOL_F; | |
282 | } | |
283 | ||
28b06554 | 284 | SCM_NEWCELL2 (lsym); |
6a0476fd | 285 | SCM_SET_SYMBOL_CHARS (lsym, duplicate_string (name, len)); |
28b06554 | 286 | SCM_SET_SYMBOL_HASH (lsym, raw_hash); |
0f8c9efa | 287 | SCM_SET_PROP_SLOTS (lsym, scm_cons (SCM_BOOL_F, SCM_EOL)); |
93778877 | 288 | SCM_SET_SYMBOL_LENGTH (lsym, (long) len); |
0f2d19dd | 289 | |
bc66755e | 290 | if (SCM_FALSEP (obarray)) |
0f2d19dd JB |
291 | { |
292 | SCM answer; | |
293 | SCM_REALLOW_INTS; | |
294 | SCM_NEWCELL (answer); | |
295 | SCM_DEFER_INTS; | |
25d8012c MD |
296 | SCM_SETCAR (answer, lsym); |
297 | SCM_SETCDR (answer, SCM_UNDEFINED); | |
0f2d19dd JB |
298 | SCM_REALLOW_INTS; |
299 | return answer; | |
300 | } | |
301 | else | |
302 | { | |
303 | SCM a; | |
304 | SCM b; | |
305 | ||
306 | SCM_NEWCELL (a); | |
307 | SCM_NEWCELL (b); | |
308 | SCM_SETCAR (a, lsym); | |
309 | SCM_SETCDR (a, SCM_UNDEFINED); | |
310 | SCM_SETCAR (b, a); | |
28b06554 DH |
311 | SCM_SETCDR (b, SCM_VELTS(obarray)[hash]); |
312 | SCM_VELTS(obarray)[hash] = b; | |
0f2d19dd JB |
313 | SCM_REALLOW_INTS; |
314 | return SCM_CAR (b); | |
315 | } | |
316 | } | |
317 | ||
1cc91f1b | 318 | |
23ade5e7 DH |
319 | SCM |
320 | scm_mem2symbol (const char *mem, scm_sizet len) | |
321 | { | |
322 | return SCM_CAR (scm_intern_obarray_soft (mem, len, scm_symhash, 0)); | |
323 | } | |
324 | ||
325 | ||
326 | SCM | |
327 | scm_str2symbol (const char *str) | |
328 | { | |
329 | return SCM_CAR (scm_intern_obarray_soft (str, strlen (str), scm_symhash, 0)); | |
330 | } | |
331 | ||
332 | ||
0f2d19dd | 333 | SCM |
1bbd0b84 | 334 | scm_intern_obarray (const char *name,scm_sizet len,SCM obarray) |
0f2d19dd JB |
335 | { |
336 | return scm_intern_obarray_soft (name, len, obarray, 0); | |
337 | } | |
338 | ||
339 | ||
0f2d19dd | 340 | SCM |
1bbd0b84 | 341 | scm_intern (const char *name,scm_sizet len) |
0f2d19dd JB |
342 | { |
343 | return scm_intern_obarray (name, len, scm_symhash); | |
344 | } | |
345 | ||
1cc91f1b | 346 | |
0f2d19dd | 347 | SCM |
1bbd0b84 | 348 | scm_intern0 (const char * name) |
0f2d19dd JB |
349 | { |
350 | return scm_intern (name, strlen (name)); | |
351 | } | |
352 | ||
353 | ||
5aab5d96 | 354 | /* Intern the symbol named NAME in scm_symhash, NAME is null-terminated. */ |
0f2d19dd | 355 | SCM |
1bbd0b84 | 356 | scm_sysintern0_no_module_lookup (const char *name) |
0f2d19dd JB |
357 | { |
358 | SCM easy_answer; | |
359 | SCM_DEFER_INTS; | |
360 | easy_answer = scm_intern_obarray_soft (name, strlen (name), scm_symhash, 1); | |
361 | if (SCM_NIMP (easy_answer)) | |
362 | { | |
0f2d19dd JB |
363 | SCM_ALLOW_INTS; |
364 | return easy_answer; | |
365 | } | |
366 | else | |
367 | { | |
368 | SCM lsym; | |
369 | scm_sizet len = strlen (name); | |
28b06554 | 370 | scm_sizet raw_hash = scm_string_hash ((unsigned char *) name, len); |
93d40df2 | 371 | scm_sizet hash = raw_hash % SCM_VECTOR_LENGTH (scm_symhash); |
28b06554 DH |
372 | |
373 | SCM_NEWCELL2 (lsym); | |
6a0476fd | 374 | SCM_SET_SYMBOL_CHARS (lsym, name); |
28b06554 | 375 | SCM_SET_SYMBOL_HASH (lsym, raw_hash); |
0f8c9efa | 376 | SCM_SET_PROP_SLOTS (lsym, scm_cons (SCM_BOOL_F, SCM_EOL)); |
93778877 | 377 | SCM_SET_SYMBOL_LENGTH (lsym, (long) len); |
28b06554 | 378 | |
5aab5d96 | 379 | lsym = scm_cons (lsym, SCM_UNDEFINED); |
28b06554 | 380 | SCM_VELTS (scm_symhash)[hash] = scm_cons (lsym, SCM_VELTS (scm_symhash)[hash]); |
0f2d19dd JB |
381 | SCM_ALLOW_INTS; |
382 | return lsym; | |
383 | } | |
384 | } | |
385 | ||
9b8d3288 MV |
386 | /* Intern the symbol named NAME in scm_symhash, and give it the value |
387 | VAL. NAME is null-terminated. Use the current top_level lookup | |
388 | closure to give NAME its value. | |
389 | */ | |
390 | SCM | |
1bbd0b84 | 391 | scm_sysintern (const char *name, SCM val) |
5aab5d96 MD |
392 | { |
393 | SCM vcell = scm_sysintern0 (name); | |
394 | SCM_SETCDR (vcell, val); | |
395 | return vcell; | |
396 | } | |
397 | ||
398 | SCM | |
1bbd0b84 | 399 | scm_sysintern0 (const char *name) |
9b8d3288 MV |
400 | { |
401 | SCM lookup_proc; | |
eb8db440 MD |
402 | if (scm_module_system_booted_p |
403 | && SCM_NIMP (lookup_proc = SCM_TOP_LEVEL_LOOKUP_CLOSURE)) | |
9b8d3288 | 404 | { |
38ae064c | 405 | SCM sym = scm_str2symbol (name); |
9b8d3288 | 406 | SCM vcell = scm_sym2vcell (sym, lookup_proc, SCM_BOOL_T); |
bc66755e | 407 | if (SCM_FALSEP (vcell)) |
5d2d2ffc | 408 | scm_misc_error ("sysintern0", "can't define variable", sym); |
9b8d3288 MV |
409 | return vcell; |
410 | } | |
411 | else | |
5aab5d96 | 412 | return scm_sysintern0_no_module_lookup (name); |
9b8d3288 MV |
413 | } |
414 | ||
1dd28b3d MD |
415 | /* Lookup the value of the symbol named by the nul-terminated string |
416 | NAME in the current module. */ | |
417 | SCM | |
1bbd0b84 | 418 | scm_symbol_value0 (const char *name) |
1dd28b3d MD |
419 | { |
420 | /* This looks silly - we look up the symbol twice. But it is in | |
421 | fact necessary given the current module system because the module | |
422 | lookup closures are written in scheme which needs real symbols. */ | |
423 | SCM symbol = scm_intern_obarray_soft (name, strlen (name), scm_symhash, 0); | |
424 | SCM vcell = scm_sym2vcell (SCM_CAR (symbol), | |
7e73eaee | 425 | SCM_TOP_LEVEL_LOOKUP_CLOSURE, |
1dd28b3d MD |
426 | SCM_BOOL_F); |
427 | if (SCM_FALSEP (vcell)) | |
428 | return SCM_UNDEFINED; | |
429 | return SCM_CDR (vcell); | |
430 | } | |
431 | ||
3b3b36dd | 432 | SCM_DEFINE (scm_symbol_p, "symbol?", 1, 0, 0, |
8e93e199 | 433 | (SCM obj), |
5ffe9968 | 434 | "Returns @t{#t} if @var{obj} is a symbol, otherwise returns @t{#f}. (r5rs)") |
1bbd0b84 | 435 | #define FUNC_NAME s_scm_symbol_p |
0f2d19dd | 436 | { |
8e93e199 | 437 | return SCM_BOOL (SCM_SYMBOLP (obj)); |
0f2d19dd | 438 | } |
1bbd0b84 | 439 | #undef FUNC_NAME |
0f2d19dd | 440 | |
3b3b36dd | 441 | SCM_DEFINE (scm_symbol_to_string, "symbol->string", 1, 0, 0, |
1bbd0b84 | 442 | (SCM s), |
5ffe9968 | 443 | "Returns the name of @var{symbol} as a string. If the symbol was part of\n" |
ae42688c NJ |
444 | "an object returned as the value of a literal expression (section\n" |
445 | "@pxref{Literal expressions,,,r4rs, The Revised^4 Report on Scheme}) or\n" | |
446 | "by a call to the @samp{read} procedure, and its name contains alphabetic\n" | |
447 | "characters, then the string returned will contain characters in the\n" | |
448 | "implementation's preferred standard case---some implementations will\n" | |
449 | "prefer upper case, others lower case. If the symbol was returned by\n" | |
450 | "@samp{string->symbol}, the case of characters in the string returned\n" | |
451 | "will be the same as the case in the string that was passed to\n" | |
452 | "@samp{string->symbol}. It is an error to apply mutation procedures like\n" | |
453 | "@code{string-set!} to strings returned by this procedure. (r5rs)\n\n" | |
5ffe9968 GB |
454 | "The following examples assume that the implementation's standard case is\n" |
455 | "lower case:\n\n" | |
456 | "@format\n" | |
457 | "@t{(symbol->string 'flying-fish) \n" | |
458 | " ==> \"flying-fish\"\n" | |
459 | "(symbol->string 'Martin) ==> \"martin\"\n" | |
460 | "(symbol->string\n" | |
ae42688c NJ |
461 | " (string->symbol \"Malvina\")) \n" |
462 | " ==> \"Malvina\"\n" | |
5ffe9968 GB |
463 | "}\n" |
464 | "@end format") | |
1bbd0b84 | 465 | #define FUNC_NAME s_scm_symbol_to_string |
0f2d19dd | 466 | { |
28b06554 | 467 | SCM_VALIDATE_SYMBOL (1, s); |
9fd38a3d | 468 | return scm_makfromstr (SCM_SYMBOL_CHARS (s), SCM_SYMBOL_LENGTH (s), 0); |
0f2d19dd | 469 | } |
1bbd0b84 | 470 | #undef FUNC_NAME |
0f2d19dd JB |
471 | |
472 | ||
3b3b36dd | 473 | SCM_DEFINE (scm_string_to_symbol, "string->symbol", 1, 0, 0, |
1bbd0b84 | 474 | (SCM s), |
5ffe9968 GB |
475 | "Returns the symbol whose name is @var{string}. This procedure can\n" |
476 | "create symbols with names containing special characters or letters in\n" | |
477 | "the non-standard case, but it is usually a bad idea to create such\n" | |
478 | "symbols because in some implementations of Scheme they cannot be read as\n" | |
479 | "themselves. See @samp{symbol->string}.\n\n" | |
480 | "The following examples assume that the implementation's standard case is\n" | |
481 | "lower case:\n\n" | |
482 | "@format\n" | |
483 | "@t{(eq? 'mISSISSIppi 'mississippi) \n" | |
484 | " ==> #t\n" | |
485 | "(string->symbol \"mISSISSIppi\") \n" | |
486 | " ==>\n" | |
487 | " @r{}the symbol with name \"mISSISSIppi\"\n" | |
488 | "(eq? 'bitBlt (string->symbol \"bitBlt\")) \n" | |
489 | " ==> #f\n" | |
490 | "(eq? 'JollyWog\n" | |
491 | " (string->symbol\n" | |
492 | " (symbol->string 'JollyWog))) \n" | |
493 | " ==> #t\n" | |
494 | "(string=? \"K. Harper, M.D.\"\n" | |
495 | " (symbol->string\n" | |
496 | " (string->symbol \"K. Harper, M.D.\"))) \n" | |
497 | " ==> #t\n" | |
498 | "}\n" | |
499 | "@end format") | |
1bbd0b84 | 500 | #define FUNC_NAME s_scm_string_to_symbol |
0f2d19dd | 501 | { |
38ae064c DH |
502 | SCM_VALIDATE_STRING (1, s); |
503 | return scm_mem2symbol (SCM_STRING_CHARS (s), SCM_STRING_LENGTH (s)); | |
0f2d19dd | 504 | } |
1bbd0b84 | 505 | #undef FUNC_NAME |
0f2d19dd JB |
506 | |
507 | ||
3b3b36dd | 508 | SCM_DEFINE (scm_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0, |
1bbd0b84 | 509 | (SCM o, SCM s, SCM softp), |
a3c8b9fc MD |
510 | "Intern a new symbol in @var{obarray}, a symbol table, with name\n" |
511 | "@var{string}.\n\n" | |
512 | "If @var{obarray} is @code{#f}, use the default system symbol table. If\n" | |
513 | "@var{obarray} is @code{#t}, the symbol should not be interned in any\n" | |
514 | "symbol table; merely return the pair (@var{symbol}\n" | |
515 | ". @var{#<undefined>}).\n\n" | |
516 | "The @var{soft?} argument determines whether new symbol table entries\n" | |
517 | "should be created when the specified symbol is not already present in\n" | |
518 | "@var{obarray}. If @var{soft?} is specified and is a true value, then\n" | |
519 | "new entries should not be added for symbols not already present in the\n" | |
520 | "table; instead, simply return @code{#f}.") | |
1bbd0b84 | 521 | #define FUNC_NAME s_scm_string_to_obarray_symbol |
0f2d19dd JB |
522 | { |
523 | SCM vcell; | |
524 | SCM answer; | |
525 | int softness; | |
526 | ||
a6d9e5ab | 527 | SCM_VALIDATE_STRING (2, s); |
bc66755e | 528 | SCM_ASSERT (SCM_BOOLP (o) || SCM_VECTORP (o), o, SCM_ARG1, FUNC_NAME); |
0f2d19dd | 529 | |
bc66755e | 530 | softness = (!SCM_UNBNDP (softp) && !SCM_FALSEP(softp)); |
0f2d19dd | 531 | /* iron out some screwy calling conventions */ |
bc66755e | 532 | if (SCM_FALSEP (o)) |
0f2d19dd | 533 | o = scm_symhash; |
9a09deb1 | 534 | else if (SCM_EQ_P (o, SCM_BOOL_T)) |
0f2d19dd JB |
535 | o = SCM_BOOL_F; |
536 | ||
34f0f2b8 | 537 | vcell = scm_intern_obarray_soft (SCM_STRING_CHARS(s), |
a6d9e5ab | 538 | SCM_STRING_LENGTH (s), |
49bc24fe MD |
539 | o, |
540 | softness); | |
bc66755e | 541 | if (SCM_FALSEP (vcell)) |
0f2d19dd JB |
542 | return vcell; |
543 | answer = SCM_CAR (vcell); | |
0f2d19dd JB |
544 | return answer; |
545 | } | |
1bbd0b84 | 546 | #undef FUNC_NAME |
0f2d19dd | 547 | |
3b3b36dd | 548 | SCM_DEFINE (scm_intern_symbol, "intern-symbol", 2, 0, 0, |
1bbd0b84 | 549 | (SCM o, SCM s), |
b380b885 MD |
550 | "Add a new symbol to @var{obarray} with name @var{string}, bound to an\n" |
551 | "unspecified initial value. The symbol table is not modified if a symbol\n" | |
552 | "with this name is already present.") | |
1bbd0b84 | 553 | #define FUNC_NAME s_scm_intern_symbol |
0f2d19dd | 554 | { |
49bc24fe | 555 | scm_sizet hval; |
3b3b36dd | 556 | SCM_VALIDATE_SYMBOL (2,s); |
bc66755e | 557 | if (SCM_FALSEP (o)) |
49bc24fe | 558 | o = scm_symhash; |
3b3b36dd | 559 | SCM_VALIDATE_VECTOR (1,o); |
0f87853a | 560 | hval = SCM_SYMBOL_HASH (s) % SCM_VECTOR_LENGTH (o); |
49bc24fe MD |
561 | /* If the symbol is already interned, simply return. */ |
562 | SCM_REDEFER_INTS; | |
563 | { | |
564 | SCM lsym; | |
565 | SCM sym; | |
566 | for (lsym = SCM_VELTS (o)[hval]; | |
567 | SCM_NIMP (lsym); | |
568 | lsym = SCM_CDR (lsym)) | |
569 | { | |
570 | sym = SCM_CAR (lsym); | |
bc66755e | 571 | if (SCM_EQ_P (SCM_CAR (sym), s)) |
49bc24fe MD |
572 | { |
573 | SCM_REALLOW_INTS; | |
574 | return SCM_UNSPECIFIED; | |
575 | } | |
576 | } | |
577 | SCM_VELTS (o)[hval] = | |
578 | scm_acons (s, SCM_UNDEFINED, SCM_VELTS (o)[hval]); | |
579 | } | |
580 | SCM_REALLOW_INTS; | |
581 | return SCM_UNSPECIFIED; | |
0f2d19dd | 582 | } |
1bbd0b84 | 583 | #undef FUNC_NAME |
0f2d19dd | 584 | |
3b3b36dd | 585 | SCM_DEFINE (scm_unintern_symbol, "unintern-symbol", 2, 0, 0, |
1bbd0b84 | 586 | (SCM o, SCM s), |
b380b885 MD |
587 | "Remove the symbol with name @var{string} from @var{obarray}. This\n" |
588 | "function returns @code{#t} if the symbol was present and @code{#f}\n" | |
589 | "otherwise.") | |
1bbd0b84 | 590 | #define FUNC_NAME s_scm_unintern_symbol |
0f2d19dd | 591 | { |
49bc24fe | 592 | scm_sizet hval; |
3b3b36dd | 593 | SCM_VALIDATE_SYMBOL (2,s); |
bc66755e | 594 | if (SCM_FALSEP (o)) |
49bc24fe | 595 | o = scm_symhash; |
3b3b36dd | 596 | SCM_VALIDATE_VECTOR (1,o); |
0f87853a | 597 | hval = SCM_SYMBOL_HASH (s) % SCM_VECTOR_LENGTH (o); |
49bc24fe MD |
598 | SCM_DEFER_INTS; |
599 | { | |
600 | SCM lsym_follow; | |
601 | SCM lsym; | |
602 | SCM sym; | |
603 | for (lsym = SCM_VELTS (o)[hval], lsym_follow = SCM_BOOL_F; | |
604 | SCM_NIMP (lsym); | |
605 | lsym_follow = lsym, lsym = SCM_CDR (lsym)) | |
606 | { | |
607 | sym = SCM_CAR (lsym); | |
bc66755e | 608 | if (SCM_EQ_P (SCM_CAR (sym), s)) |
49bc24fe MD |
609 | { |
610 | /* Found the symbol to unintern. */ | |
bc66755e | 611 | if (SCM_FALSEP (lsym_follow)) |
49bc24fe MD |
612 | SCM_VELTS(o)[hval] = lsym; |
613 | else | |
25d8012c | 614 | SCM_SETCDR (lsym_follow, SCM_CDR(lsym)); |
49bc24fe MD |
615 | SCM_ALLOW_INTS; |
616 | return SCM_BOOL_T; | |
617 | } | |
618 | } | |
619 | } | |
620 | SCM_ALLOW_INTS; | |
621 | return SCM_BOOL_F; | |
0f2d19dd | 622 | } |
1bbd0b84 | 623 | #undef FUNC_NAME |
0f2d19dd | 624 | |
3b3b36dd | 625 | SCM_DEFINE (scm_symbol_binding, "symbol-binding", 2, 0, 0, |
1bbd0b84 | 626 | (SCM o, SCM s), |
b380b885 MD |
627 | "Look up in @var{obarray} the symbol whose name is @var{string}, and\n" |
628 | "return the value to which it is bound. If @var{obarray} is @code{#f},\n" | |
629 | "use the global symbol table. If @var{string} is not interned in\n" | |
630 | "@var{obarray}, an error is signalled.") | |
1bbd0b84 | 631 | #define FUNC_NAME s_scm_symbol_binding |
0f2d19dd JB |
632 | { |
633 | SCM vcell; | |
3b3b36dd | 634 | SCM_VALIDATE_SYMBOL (2,s); |
bc66755e | 635 | if (SCM_FALSEP (o)) |
0f2d19dd | 636 | o = scm_symhash; |
3b3b36dd | 637 | SCM_VALIDATE_VECTOR (1,o); |
0f2d19dd JB |
638 | vcell = scm_sym2ovcell (s, o); |
639 | return SCM_CDR(vcell); | |
640 | } | |
1bbd0b84 | 641 | #undef FUNC_NAME |
0f2d19dd JB |
642 | |
643 | ||
3b3b36dd | 644 | SCM_DEFINE (scm_symbol_interned_p, "symbol-interned?", 2, 0, 0, |
1bbd0b84 | 645 | (SCM o, SCM s), |
b380b885 MD |
646 | "Return @var{#t} if @var{obarray} contains a symbol with name\n" |
647 | "@var{string}, and @var{#f} otherwise.") | |
1bbd0b84 | 648 | #define FUNC_NAME s_scm_symbol_interned_p |
0f2d19dd JB |
649 | { |
650 | SCM vcell; | |
3b3b36dd | 651 | SCM_VALIDATE_SYMBOL (2,s); |
bc66755e | 652 | if (SCM_FALSEP (o)) |
0f2d19dd | 653 | o = scm_symhash; |
3b3b36dd | 654 | SCM_VALIDATE_VECTOR (1,o); |
0f2d19dd | 655 | vcell = scm_sym2ovcell_soft (s, o); |
bc66755e | 656 | if (SCM_IMP (vcell) && SCM_EQ_P (o, scm_symhash)) |
0f2d19dd JB |
657 | vcell = scm_sym2ovcell_soft (s, scm_weak_symhash); |
658 | return (SCM_NIMP(vcell) | |
659 | ? SCM_BOOL_T | |
660 | : SCM_BOOL_F); | |
661 | } | |
1bbd0b84 | 662 | #undef FUNC_NAME |
0f2d19dd JB |
663 | |
664 | ||
3b3b36dd | 665 | SCM_DEFINE (scm_symbol_bound_p, "symbol-bound?", 2, 0, 0, |
1bbd0b84 | 666 | (SCM o, SCM s), |
b380b885 MD |
667 | "Return @var{#t} if @var{obarray} contains a symbol with name\n" |
668 | "@var{string} bound to a defined value. This differs from\n" | |
669 | "@var{symbol-bound?} in that the mere mention of a symbol usually causes\n" | |
670 | "it to be interned; @code{symbol-bound?} determines whether a symbol has\n" | |
671 | "been given any meaningful value.") | |
1bbd0b84 | 672 | #define FUNC_NAME s_scm_symbol_bound_p |
0f2d19dd JB |
673 | { |
674 | SCM vcell; | |
3b3b36dd | 675 | SCM_VALIDATE_SYMBOL (2,s); |
bc66755e | 676 | if (SCM_FALSEP (o)) |
0f2d19dd | 677 | o = scm_symhash; |
3b3b36dd | 678 | SCM_VALIDATE_VECTOR (1,o); |
0f2d19dd | 679 | vcell = scm_sym2ovcell_soft (s, o); |
bc66755e | 680 | return SCM_BOOL (SCM_NIMP (vcell) && !SCM_UNBNDP (SCM_CDR (vcell))); |
0f2d19dd | 681 | } |
1bbd0b84 | 682 | #undef FUNC_NAME |
0f2d19dd JB |
683 | |
684 | ||
3b3b36dd | 685 | SCM_DEFINE (scm_symbol_set_x, "symbol-set!", 3, 0, 0, |
1bbd0b84 | 686 | (SCM o, SCM s, SCM v), |
b380b885 MD |
687 | "Find the symbol in @var{obarray} whose name is @var{string}, and rebind\n" |
688 | "it to @var{value}. An error is signalled if @var{string} is not present\n" | |
689 | "in @var{obarray}.") | |
1bbd0b84 | 690 | #define FUNC_NAME s_scm_symbol_set_x |
0f2d19dd JB |
691 | { |
692 | SCM vcell; | |
3b3b36dd | 693 | SCM_VALIDATE_SYMBOL (2,s); |
bc66755e | 694 | if (SCM_FALSEP (o)) |
0f2d19dd | 695 | o = scm_symhash; |
3b3b36dd | 696 | SCM_VALIDATE_VECTOR (1,o); |
0f2d19dd | 697 | vcell = scm_sym2ovcell (s, o); |
25d8012c | 698 | SCM_SETCDR (vcell, v); |
0f2d19dd JB |
699 | return SCM_UNSPECIFIED; |
700 | } | |
1bbd0b84 | 701 | #undef FUNC_NAME |
0f2d19dd | 702 | |
0f2d19dd | 703 | |
3b3b36dd | 704 | SCM_DEFINE (scm_symbol_fref, "symbol-fref", 1, 0, 0, |
1bbd0b84 | 705 | (SCM s), |
b380b885 | 706 | "Return the contents of @var{symbol}'s @dfn{function slot}.") |
1bbd0b84 | 707 | #define FUNC_NAME s_scm_symbol_fref |
0f2d19dd | 708 | { |
3b3b36dd | 709 | SCM_VALIDATE_SYMBOL (1,s); |
0f2d19dd JB |
710 | return SCM_SYMBOL_FUNC (s); |
711 | } | |
1bbd0b84 | 712 | #undef FUNC_NAME |
0f2d19dd JB |
713 | |
714 | ||
3b3b36dd | 715 | SCM_DEFINE (scm_symbol_pref, "symbol-pref", 1, 0, 0, |
1bbd0b84 | 716 | (SCM s), |
b380b885 | 717 | "Return the @dfn{property list} currently associated with @var{symbol}.") |
1bbd0b84 | 718 | #define FUNC_NAME s_scm_symbol_pref |
0f2d19dd | 719 | { |
3b3b36dd | 720 | SCM_VALIDATE_SYMBOL (1,s); |
0f2d19dd JB |
721 | return SCM_SYMBOL_PROPS (s); |
722 | } | |
1bbd0b84 | 723 | #undef FUNC_NAME |
0f2d19dd JB |
724 | |
725 | ||
3b3b36dd | 726 | SCM_DEFINE (scm_symbol_fset_x, "symbol-fset!", 2, 0, 0, |
1bbd0b84 | 727 | (SCM s, SCM val), |
b380b885 | 728 | "Change the binding of @var{symbol}'s function slot.") |
1bbd0b84 | 729 | #define FUNC_NAME s_scm_symbol_fset_x |
0f2d19dd | 730 | { |
3b3b36dd | 731 | SCM_VALIDATE_SYMBOL (1,s); |
cf551a2b | 732 | SCM_SET_SYMBOL_FUNC (s, val); |
0f2d19dd JB |
733 | return SCM_UNSPECIFIED; |
734 | } | |
1bbd0b84 | 735 | #undef FUNC_NAME |
0f2d19dd JB |
736 | |
737 | ||
3b3b36dd | 738 | SCM_DEFINE (scm_symbol_pset_x, "symbol-pset!", 2, 0, 0, |
1bbd0b84 | 739 | (SCM s, SCM val), |
b380b885 | 740 | "Change the binding of @var{symbol}'s property slot.") |
1bbd0b84 | 741 | #define FUNC_NAME s_scm_symbol_pset_x |
0f2d19dd | 742 | { |
3b3b36dd | 743 | SCM_VALIDATE_SYMBOL (1,s); |
0f2d19dd | 744 | SCM_DEFER_INTS; |
cf551a2b | 745 | SCM_SET_SYMBOL_PROPS (s, val); |
0f2d19dd JB |
746 | SCM_ALLOW_INTS; |
747 | return SCM_UNSPECIFIED; | |
748 | } | |
1bbd0b84 | 749 | #undef FUNC_NAME |
0f2d19dd JB |
750 | |
751 | ||
3b3b36dd | 752 | SCM_DEFINE (scm_symbol_hash, "symbol-hash", 1, 0, 0, |
28b06554 DH |
753 | (SCM symbol), |
754 | "Return a hash value for @var{symbol}.") | |
1bbd0b84 | 755 | #define FUNC_NAME s_scm_symbol_hash |
0f2d19dd | 756 | { |
28b06554 DH |
757 | SCM_VALIDATE_SYMBOL (1, symbol); |
758 | return SCM_MAKINUM (SCM_SYMBOL_HASH (symbol)); | |
0f2d19dd | 759 | } |
1bbd0b84 | 760 | #undef FUNC_NAME |
0f2d19dd JB |
761 | |
762 | ||
b2530d66 | 763 | static void |
1bbd0b84 | 764 | copy_and_prune_obarray (SCM from, SCM to) |
b2530d66 MD |
765 | { |
766 | int i; | |
9fd38a3d | 767 | int length = SCM_VECTOR_LENGTH (from); |
b2530d66 MD |
768 | for (i = 0; i < length; ++i) |
769 | { | |
770 | SCM head = SCM_VELTS (from)[i]; /* GC protection */ | |
771 | SCM ls = head; | |
772 | SCM res = SCM_EOL; | |
773 | SCM *lloc = &res; | |
774 | while (SCM_NIMP (ls)) | |
775 | { | |
776 | if (!SCM_UNBNDP (SCM_CDAR (ls))) | |
777 | { | |
778 | *lloc = scm_cons (SCM_CAR (ls), SCM_EOL); | |
779 | lloc = SCM_CDRLOC (*lloc); | |
780 | } | |
781 | ls = SCM_CDR (ls); | |
782 | } | |
783 | SCM_VELTS (to)[i] = res; | |
784 | } | |
785 | } | |
786 | ||
787 | ||
3b3b36dd | 788 | SCM_DEFINE (scm_builtin_bindings, "builtin-bindings", 0, 0, 0, |
5ffe9968 | 789 | (), |
b380b885 MD |
790 | "Create and return a copy of the global symbol table, removing all\n" |
791 | "unbound symbols.") | |
1bbd0b84 | 792 | #define FUNC_NAME s_scm_builtin_bindings |
b2530d66 | 793 | { |
9fd38a3d | 794 | int length = SCM_VECTOR_LENGTH (scm_symhash); |
a8741caa | 795 | SCM obarray = scm_make_vector (SCM_MAKINUM (length), SCM_EOL); |
b2530d66 MD |
796 | copy_and_prune_obarray (scm_symhash, obarray); |
797 | return obarray; | |
798 | } | |
1bbd0b84 | 799 | #undef FUNC_NAME |
b2530d66 MD |
800 | |
801 | ||
3b3b36dd | 802 | SCM_DEFINE (scm_builtin_weak_bindings, "builtin-weak-bindings", 0, 0, 0, |
5ffe9968 | 803 | (), |
b380b885 | 804 | "") |
1bbd0b84 | 805 | #define FUNC_NAME s_scm_builtin_weak_bindings |
b2530d66 | 806 | { |
9fd38a3d | 807 | int length = SCM_VECTOR_LENGTH (scm_weak_symhash); |
b2530d66 MD |
808 | SCM obarray = scm_make_doubly_weak_hash_table (SCM_MAKINUM (length)); |
809 | copy_and_prune_obarray (scm_weak_symhash, obarray); | |
810 | return obarray; | |
811 | } | |
1bbd0b84 | 812 | #undef FUNC_NAME |
b2530d66 | 813 | |
e1313058 MD |
814 | #define MAX_PREFIX_LENGTH 30 |
815 | ||
1ff4df7a | 816 | static int gensym_counter; |
e1313058 MD |
817 | |
818 | SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0, | |
819 | (SCM prefix), | |
820 | "Create a new symbol with name constructed from a prefix and a counter value.\n" | |
821 | "The string PREFIX can be specified as an optional argument.\n" | |
822 | "Default prefix is @code{g}. The counter is increased by 1 at each call.\n" | |
823 | "There is no provision for resetting the counter.") | |
1bbd0b84 | 824 | #define FUNC_NAME s_scm_gensym |
1ff4df7a | 825 | { |
e1313058 MD |
826 | char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN]; |
827 | char *name = buf; | |
828 | int len; | |
829 | if (SCM_UNBNDP (prefix)) | |
830 | { | |
831 | name[0] = 'g'; | |
832 | len = 1; | |
833 | } | |
1ff4df7a | 834 | else |
c64d02c5 | 835 | { |
d1ca2c64 DH |
836 | SCM_VALIDATE_STRING (1, prefix); |
837 | len = SCM_STRING_LENGTH (prefix); | |
e1313058 MD |
838 | if (len > MAX_PREFIX_LENGTH) |
839 | name = SCM_MUST_MALLOC (MAX_PREFIX_LENGTH + SCM_INTBUFLEN); | |
34f0f2b8 | 840 | strncpy (name, SCM_STRING_CHARS (prefix), len); |
c64d02c5 | 841 | } |
e1313058 MD |
842 | { |
843 | int n_digits = scm_iint2str (gensym_counter++, 10, &name[len]); | |
38ae064c | 844 | SCM res = scm_mem2symbol (name, len + n_digits); |
e1313058 MD |
845 | if (name != buf) |
846 | scm_must_free (name); | |
847 | return res; | |
848 | } | |
849 | } | |
850 | #undef FUNC_NAME | |
1bbd0b84 | 851 | |
e1313058 MD |
852 | static int gentemp_counter; |
853 | ||
854 | SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0, | |
855 | (SCM prefix, SCM obarray), | |
856 | "Create a new symbol with a name unique in an obarray.\n" | |
857 | "The name is constructed from an optional string PREFIX and a counter\n" | |
858 | "value. The default prefix is @var{t}. The OBARRAY is specified as a\n" | |
859 | "second optional argument. Default is the system obarray where all\n" | |
860 | "normal symbols are interned. The counter is increased by 1 at each\n" | |
861 | "call. There is no provision for resetting the counter.") | |
862 | #define FUNC_NAME s_scm_gentemp | |
863 | { | |
864 | char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN]; | |
865 | char *name = buf; | |
866 | int len, n_digits; | |
867 | if (SCM_UNBNDP (prefix)) | |
868 | { | |
869 | name[0] = 't'; | |
870 | len = 1; | |
871 | } | |
872 | else | |
1ff4df7a | 873 | { |
d1ca2c64 DH |
874 | SCM_VALIDATE_STRING (1, prefix); |
875 | len = SCM_STRING_LENGTH (prefix); | |
e1313058 MD |
876 | if (len > MAX_PREFIX_LENGTH) |
877 | name = SCM_MUST_MALLOC (MAX_PREFIX_LENGTH + SCM_INTBUFLEN); | |
34f0f2b8 | 878 | strncpy (name, SCM_STRING_CHARS (prefix), len); |
1ff4df7a | 879 | } |
e1313058 MD |
880 | |
881 | if (SCM_UNBNDP (obarray)) | |
882 | obarray = scm_symhash; | |
1ff4df7a | 883 | else |
368cf54d | 884 | SCM_ASSERT ((SCM_VECTORP (obarray) || SCM_WVECTP (obarray)), |
1ff4df7a MD |
885 | obarray, |
886 | SCM_ARG2, | |
1bbd0b84 | 887 | FUNC_NAME); |
e1313058 MD |
888 | do |
889 | n_digits = scm_iint2str (gentemp_counter++, 10, &name[len]); | |
890 | while (!SCM_FALSEP (scm_intern_obarray_soft (name, | |
891 | len + n_digits, | |
892 | obarray, | |
893 | 1))); | |
894 | { | |
895 | SCM vcell = scm_intern_obarray_soft (name, | |
896 | len + n_digits, | |
897 | obarray, | |
898 | 0); | |
899 | if (name != buf) | |
900 | scm_must_free (name); | |
901 | return SCM_CAR (vcell); | |
902 | } | |
1ff4df7a | 903 | } |
1bbd0b84 | 904 | #undef FUNC_NAME |
1cc91f1b | 905 | |
0f2d19dd JB |
906 | void |
907 | scm_init_symbols () | |
0f2d19dd | 908 | { |
1ff4df7a | 909 | gensym_counter = 0; |
e1313058 | 910 | gentemp_counter = 0; |
8dc9439f | 911 | #ifndef SCM_MAGIC_SNARFER |
a0599745 | 912 | #include "libguile/symbols.x" |
8dc9439f | 913 | #endif |
0f2d19dd | 914 | } |
89e00824 ML |
915 | |
916 | /* | |
917 | Local Variables: | |
918 | c-file-style: "gnu" | |
919 | End: | |
920 | */ |