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 | ||
69 | ||
70 | /* NUM_HASH_BUCKETS is the number of symbol scm_hash table buckets. | |
71 | */ | |
72 | #define NUM_HASH_BUCKETS 137 | |
73 | ||
74 | \f | |
75 | ||
76 | ||
77 | /* {Symbols} | |
78 | */ | |
79 | ||
1cc91f1b | 80 | |
0f2d19dd | 81 | unsigned long |
95c9e176 | 82 | scm_strhash (const unsigned char *str, scm_sizet len, unsigned long n) |
0f2d19dd JB |
83 | { |
84 | if (len > 5) | |
85 | { | |
86 | scm_sizet i = 5; | |
87 | unsigned long h = 264 % n; | |
88 | while (i--) | |
566011b9 | 89 | h = ((h << 8) + ((unsigned) (scm_downcase (str[h % len])))) % n; |
0f2d19dd JB |
90 | return h; |
91 | } | |
92 | else | |
93 | { | |
94 | scm_sizet i = len; | |
95 | unsigned long h = 0; | |
96 | while (i) | |
566011b9 | 97 | h = ((h << 8) + ((unsigned) (scm_downcase (str[--i])))) % n; |
0f2d19dd JB |
98 | return h; |
99 | } | |
100 | } | |
101 | ||
102 | int scm_symhash_dim = NUM_HASH_BUCKETS; | |
103 | ||
104 | ||
105 | /* scm_sym2vcell | |
106 | * looks up the symbol in the symhash table. | |
107 | */ | |
1cc91f1b | 108 | |
0f2d19dd | 109 | SCM |
bccb33a9 | 110 | scm_sym2vcell (SCM sym, SCM thunk, SCM definep) |
0f2d19dd | 111 | { |
bccb33a9 | 112 | if (SCM_NIMP (thunk)) |
0f2d19dd | 113 | { |
bccb33a9 MD |
114 | SCM var; |
115 | ||
fb43bf74 | 116 | if (SCM_EVAL_CLOSURE_P (thunk)) |
bccb33a9 | 117 | /* Bypass evaluator in the standard case. */ |
fb43bf74 | 118 | var = scm_eval_closure_lookup (thunk, sym, definep); |
bccb33a9 MD |
119 | else |
120 | var = scm_apply (thunk, sym, scm_cons (definep, scm_listofnull)); | |
0f2d19dd | 121 | |
bc66755e | 122 | if (SCM_FALSEP (var)) |
0f2d19dd JB |
123 | return SCM_BOOL_F; |
124 | else | |
125 | { | |
126 | if (SCM_IMP(var) || !SCM_VARIABLEP (var)) | |
127 | scm_wta (sym, "strangely interned symbol? ", ""); | |
128 | return SCM_VARVCELL (var); | |
129 | } | |
130 | } | |
131 | else | |
132 | { | |
133 | SCM lsym; | |
134 | SCM * lsymp; | |
135 | SCM z; | |
136 | scm_sizet scm_hash = scm_strhash (SCM_UCHARS (sym), (scm_sizet) SCM_LENGTH (sym), | |
137 | (unsigned long) scm_symhash_dim); | |
138 | ||
139 | SCM_DEFER_INTS; | |
140 | for (lsym = SCM_VELTS (scm_symhash)[scm_hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) | |
141 | { | |
142 | z = SCM_CAR (lsym); | |
bc66755e | 143 | if (SCM_EQ_P (SCM_CAR (z), sym)) |
0f2d19dd JB |
144 | { |
145 | SCM_ALLOW_INTS; | |
146 | return z; | |
147 | } | |
148 | } | |
149 | ||
150 | for (lsym = *(lsymp = &SCM_VELTS (scm_weak_symhash)[scm_hash]); | |
151 | SCM_NIMP (lsym); | |
25d8012c | 152 | lsym = *(lsymp = SCM_CDRLOC (lsym))) |
0f2d19dd JB |
153 | { |
154 | 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 JB |
160 | *lsymp = SCM_CDR (lsym); |
161 | SCM_SETCDR (lsym, SCM_VELTS(scm_symhash)[scm_hash]); | |
162 | SCM_VELTS(scm_symhash)[scm_hash] = lsym; | |
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; | |
181 | scm_sizet scm_hash; | |
182 | ||
183 | scm_hash = scm_strhash (SCM_UCHARS (sym), | |
184 | (scm_sizet) SCM_LENGTH (sym), | |
185 | SCM_LENGTH (obarray)); | |
186 | SCM_REDEFER_INTS; | |
187 | for (lsym = SCM_VELTS (obarray)[scm_hash]; | |
188 | SCM_NIMP (lsym); | |
189 | lsym = SCM_CDR (lsym)) | |
190 | { | |
191 | z = SCM_CAR (lsym); | |
bc66755e | 192 | if (SCM_EQ_P (SCM_CAR (z), sym)) |
0f2d19dd JB |
193 | { |
194 | SCM_REALLOW_INTS; | |
195 | return z; | |
196 | } | |
197 | } | |
198 | SCM_REALLOW_INTS; | |
199 | return SCM_BOOL_F; | |
200 | } | |
201 | ||
1cc91f1b | 202 | |
0f2d19dd | 203 | SCM |
1bbd0b84 | 204 | scm_sym2ovcell (SCM sym, SCM obarray) |
0f2d19dd JB |
205 | { |
206 | SCM answer; | |
207 | answer = scm_sym2ovcell_soft (sym, obarray); | |
bc66755e | 208 | if (!SCM_FALSEP (answer)) |
0f2d19dd JB |
209 | return answer; |
210 | scm_wta (sym, "uninterned symbol? ", ""); | |
211 | return SCM_UNSPECIFIED; /* not reached */ | |
212 | } | |
213 | ||
8ce94504 JB |
214 | /* Intern a symbol whose name is the LEN characters at NAME in OBARRAY. |
215 | ||
216 | OBARRAY should be a vector of lists, indexed by the name's hash | |
217 | value, modulo OBARRAY's length. Each list has the form | |
218 | ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the | |
219 | value associated with that symbol (in the current module? in the | |
220 | system module?) | |
221 | ||
222 | To "intern" a symbol means: if OBARRAY already contains a symbol by | |
223 | that name, return its (SYMBOL . VALUE) pair; otherwise, create a | |
224 | new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the | |
225 | appropriate list of the OBARRAY, and return the pair. | |
226 | ||
227 | If softness is non-zero, don't create a symbol if it isn't already | |
228 | in OBARRAY; instead, just return #f. | |
229 | ||
230 | If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and | |
231 | return (SYMBOL . SCM_UNDEFINED). | |
232 | ||
233 | If OBARRAY is scm_symhash, and that doesn't contain the symbol, | |
234 | check scm_weak_symhash instead. */ | |
235 | ||
1cc91f1b | 236 | |
0f2d19dd | 237 | SCM |
1bbd0b84 | 238 | scm_intern_obarray_soft (const char *name,scm_sizet len,SCM obarray,int softness) |
0f2d19dd JB |
239 | { |
240 | SCM lsym; | |
241 | SCM z; | |
242 | register scm_sizet i; | |
243 | register unsigned char *tmp; | |
244 | scm_sizet scm_hash; | |
245 | ||
246 | SCM_REDEFER_INTS; | |
247 | ||
bc66755e | 248 | if (SCM_FALSEP (obarray)) |
0f2d19dd | 249 | { |
4f4d60fd | 250 | scm_hash = scm_strhash ((unsigned char *) name, len, 1019); |
0f2d19dd JB |
251 | goto uninterned_symbol; |
252 | } | |
253 | ||
4f4d60fd | 254 | scm_hash = scm_strhash ((unsigned char *) name, len, SCM_LENGTH (obarray)); |
0f2d19dd | 255 | |
8ce94504 JB |
256 | /* softness == -1 used to mean that it was known that the symbol |
257 | wasn't already in the obarray. I don't think there are any | |
258 | callers that use that case any more, but just in case... | |
259 | -- JimB, Oct 1996 */ | |
0f2d19dd | 260 | if (softness == -1) |
8ce94504 | 261 | abort (); |
0f2d19dd JB |
262 | |
263 | retry_new_obarray: | |
264 | for (lsym = SCM_VELTS (obarray)[scm_hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) | |
265 | { | |
266 | z = SCM_CAR (lsym); | |
267 | z = SCM_CAR (z); | |
268 | tmp = SCM_UCHARS (z); | |
269 | if (SCM_LENGTH (z) != len) | |
270 | goto trynext; | |
271 | for (i = len; i--;) | |
272 | if (((unsigned char *) name)[i] != tmp[i]) | |
273 | goto trynext; | |
274 | { | |
275 | SCM a; | |
276 | a = SCM_CAR (lsym); | |
277 | SCM_REALLOW_INTS; | |
278 | return a; | |
279 | } | |
280 | trynext:; | |
281 | } | |
282 | ||
bc66755e | 283 | if (SCM_EQ_P (obarray, scm_symhash)) |
0f2d19dd JB |
284 | { |
285 | obarray = scm_weak_symhash; | |
286 | goto retry_new_obarray; | |
287 | } | |
288 | ||
289 | uninterned_symbol: | |
290 | if (softness) | |
291 | { | |
292 | SCM_REALLOW_INTS; | |
293 | return SCM_BOOL_F; | |
294 | } | |
295 | ||
0f2d19dd JB |
296 | lsym = scm_makfromstr (name, len, SCM_SYMBOL_SLOTS); |
297 | ||
298 | SCM_SETLENGTH (lsym, (long) len, scm_tc7_msymbol); | |
0f2d19dd | 299 | SCM_SYMBOL_HASH (lsym) = scm_hash; |
cf551a2b | 300 | SCM_SET_SYMBOL_PROPS (lsym, SCM_EOL); |
bc66755e | 301 | if (SCM_FALSEP (obarray)) |
0f2d19dd JB |
302 | { |
303 | SCM answer; | |
304 | SCM_REALLOW_INTS; | |
305 | SCM_NEWCELL (answer); | |
306 | SCM_DEFER_INTS; | |
25d8012c MD |
307 | SCM_SETCAR (answer, lsym); |
308 | SCM_SETCDR (answer, SCM_UNDEFINED); | |
0f2d19dd JB |
309 | SCM_REALLOW_INTS; |
310 | return answer; | |
311 | } | |
312 | else | |
313 | { | |
314 | SCM a; | |
315 | SCM b; | |
316 | ||
317 | SCM_NEWCELL (a); | |
318 | SCM_NEWCELL (b); | |
319 | SCM_SETCAR (a, lsym); | |
320 | SCM_SETCDR (a, SCM_UNDEFINED); | |
321 | SCM_SETCAR (b, a); | |
322 | SCM_SETCDR (b, SCM_VELTS(obarray)[scm_hash]); | |
323 | SCM_VELTS(obarray)[scm_hash] = b; | |
324 | SCM_REALLOW_INTS; | |
325 | return SCM_CAR (b); | |
326 | } | |
327 | } | |
328 | ||
1cc91f1b | 329 | |
0f2d19dd | 330 | SCM |
1bbd0b84 | 331 | scm_intern_obarray (const char *name,scm_sizet len,SCM obarray) |
0f2d19dd JB |
332 | { |
333 | return scm_intern_obarray_soft (name, len, obarray, 0); | |
334 | } | |
335 | ||
336 | ||
0f2d19dd | 337 | SCM |
1bbd0b84 | 338 | scm_intern (const char *name,scm_sizet len) |
0f2d19dd JB |
339 | { |
340 | return scm_intern_obarray (name, len, scm_symhash); | |
341 | } | |
342 | ||
1cc91f1b | 343 | |
0f2d19dd | 344 | SCM |
1bbd0b84 | 345 | scm_intern0 (const char * name) |
0f2d19dd JB |
346 | { |
347 | return scm_intern (name, strlen (name)); | |
348 | } | |
349 | ||
350 | ||
5aab5d96 | 351 | /* Intern the symbol named NAME in scm_symhash, NAME is null-terminated. */ |
0f2d19dd | 352 | SCM |
1bbd0b84 | 353 | scm_sysintern0_no_module_lookup (const char *name) |
0f2d19dd JB |
354 | { |
355 | SCM easy_answer; | |
356 | SCM_DEFER_INTS; | |
357 | easy_answer = scm_intern_obarray_soft (name, strlen (name), scm_symhash, 1); | |
358 | if (SCM_NIMP (easy_answer)) | |
359 | { | |
0f2d19dd JB |
360 | SCM_ALLOW_INTS; |
361 | return easy_answer; | |
362 | } | |
363 | else | |
364 | { | |
365 | SCM lsym; | |
366 | scm_sizet len = strlen (name); | |
4f4d60fd MD |
367 | scm_sizet scm_hash = scm_strhash ((unsigned char *) name, |
368 | len, | |
369 | (unsigned long) scm_symhash_dim); | |
0f2d19dd JB |
370 | SCM_NEWCELL (lsym); |
371 | SCM_SETLENGTH (lsym, (long) len, scm_tc7_ssymbol); | |
372 | SCM_SETCHARS (lsym, name); | |
5aab5d96 | 373 | lsym = scm_cons (lsym, SCM_UNDEFINED); |
0f2d19dd JB |
374 | SCM_VELTS (scm_symhash)[scm_hash] = scm_cons (lsym, SCM_VELTS (scm_symhash)[scm_hash]); |
375 | SCM_ALLOW_INTS; | |
376 | return lsym; | |
377 | } | |
378 | } | |
379 | ||
9b8d3288 MV |
380 | /* Intern the symbol named NAME in scm_symhash, and give it the value |
381 | VAL. NAME is null-terminated. Use the current top_level lookup | |
382 | closure to give NAME its value. | |
383 | */ | |
384 | SCM | |
1bbd0b84 | 385 | scm_sysintern (const char *name, SCM val) |
5aab5d96 MD |
386 | { |
387 | SCM vcell = scm_sysintern0 (name); | |
388 | SCM_SETCDR (vcell, val); | |
389 | return vcell; | |
390 | } | |
391 | ||
392 | SCM | |
1bbd0b84 | 393 | scm_sysintern0 (const char *name) |
9b8d3288 MV |
394 | { |
395 | SCM lookup_proc; | |
eb8db440 MD |
396 | if (scm_module_system_booted_p |
397 | && SCM_NIMP (lookup_proc = SCM_TOP_LEVEL_LOOKUP_CLOSURE)) | |
9b8d3288 MV |
398 | { |
399 | SCM sym = SCM_CAR (scm_intern0 (name)); | |
400 | SCM vcell = scm_sym2vcell (sym, lookup_proc, SCM_BOOL_T); | |
bc66755e | 401 | if (SCM_FALSEP (vcell)) |
5d2d2ffc | 402 | scm_misc_error ("sysintern0", "can't define variable", sym); |
9b8d3288 MV |
403 | return vcell; |
404 | } | |
405 | else | |
5aab5d96 | 406 | return scm_sysintern0_no_module_lookup (name); |
9b8d3288 MV |
407 | } |
408 | ||
1dd28b3d MD |
409 | /* Lookup the value of the symbol named by the nul-terminated string |
410 | NAME in the current module. */ | |
411 | SCM | |
1bbd0b84 | 412 | scm_symbol_value0 (const char *name) |
1dd28b3d MD |
413 | { |
414 | /* This looks silly - we look up the symbol twice. But it is in | |
415 | fact necessary given the current module system because the module | |
416 | lookup closures are written in scheme which needs real symbols. */ | |
417 | SCM symbol = scm_intern_obarray_soft (name, strlen (name), scm_symhash, 0); | |
418 | SCM vcell = scm_sym2vcell (SCM_CAR (symbol), | |
7e73eaee | 419 | SCM_TOP_LEVEL_LOOKUP_CLOSURE, |
1dd28b3d MD |
420 | SCM_BOOL_F); |
421 | if (SCM_FALSEP (vcell)) | |
422 | return SCM_UNDEFINED; | |
423 | return SCM_CDR (vcell); | |
424 | } | |
425 | ||
3b3b36dd | 426 | SCM_DEFINE (scm_symbol_p, "symbol?", 1, 0, 0, |
5ffe9968 GB |
427 | (SCM obj), |
428 | "Returns @t{#t} if @var{obj} is a symbol, otherwise returns @t{#f}. (r5rs)") | |
1bbd0b84 | 429 | #define FUNC_NAME s_scm_symbol_p |
0f2d19dd | 430 | { |
5ffe9968 GB |
431 | if SCM_IMP(obj) return SCM_BOOL_F; |
432 | return SCM_BOOL(SCM_SYMBOLP(obj)); | |
0f2d19dd | 433 | } |
1bbd0b84 | 434 | #undef FUNC_NAME |
0f2d19dd | 435 | |
3b3b36dd | 436 | SCM_DEFINE (scm_symbol_to_string, "symbol->string", 1, 0, 0, |
1bbd0b84 | 437 | (SCM s), |
5ffe9968 | 438 | "Returns the name of @var{symbol} as a string. If the symbol was part of\n" |
ae42688c NJ |
439 | "an object returned as the value of a literal expression (section\n" |
440 | "@pxref{Literal expressions,,,r4rs, The Revised^4 Report on Scheme}) or\n" | |
441 | "by a call to the @samp{read} procedure, and its name contains alphabetic\n" | |
442 | "characters, then the string returned will contain characters in the\n" | |
443 | "implementation's preferred standard case---some implementations will\n" | |
444 | "prefer upper case, others lower case. If the symbol was returned by\n" | |
445 | "@samp{string->symbol}, the case of characters in the string returned\n" | |
446 | "will be the same as the case in the string that was passed to\n" | |
447 | "@samp{string->symbol}. It is an error to apply mutation procedures like\n" | |
448 | "@code{string-set!} to strings returned by this procedure. (r5rs)\n\n" | |
5ffe9968 GB |
449 | "The following examples assume that the implementation's standard case is\n" |
450 | "lower case:\n\n" | |
451 | "@format\n" | |
452 | "@t{(symbol->string 'flying-fish) \n" | |
453 | " ==> \"flying-fish\"\n" | |
454 | "(symbol->string 'Martin) ==> \"martin\"\n" | |
455 | "(symbol->string\n" | |
ae42688c NJ |
456 | " (string->symbol \"Malvina\")) \n" |
457 | " ==> \"Malvina\"\n" | |
5ffe9968 GB |
458 | "}\n" |
459 | "@end format") | |
1bbd0b84 | 460 | #define FUNC_NAME s_scm_symbol_to_string |
0f2d19dd | 461 | { |
3b3b36dd | 462 | SCM_VALIDATE_SYMBOL (1,s); |
49bc24fe | 463 | return scm_makfromstr(SCM_CHARS(s), (scm_sizet)SCM_LENGTH(s), 0); |
0f2d19dd | 464 | } |
1bbd0b84 | 465 | #undef FUNC_NAME |
0f2d19dd JB |
466 | |
467 | ||
3b3b36dd | 468 | SCM_DEFINE (scm_string_to_symbol, "string->symbol", 1, 0, 0, |
1bbd0b84 | 469 | (SCM s), |
5ffe9968 GB |
470 | "Returns the symbol whose name is @var{string}. This procedure can\n" |
471 | "create symbols with names containing special characters or letters in\n" | |
472 | "the non-standard case, but it is usually a bad idea to create such\n" | |
473 | "symbols because in some implementations of Scheme they cannot be read as\n" | |
474 | "themselves. See @samp{symbol->string}.\n\n" | |
475 | "The following examples assume that the implementation's standard case is\n" | |
476 | "lower case:\n\n" | |
477 | "@format\n" | |
478 | "@t{(eq? 'mISSISSIppi 'mississippi) \n" | |
479 | " ==> #t\n" | |
480 | "(string->symbol \"mISSISSIppi\") \n" | |
481 | " ==>\n" | |
482 | " @r{}the symbol with name \"mISSISSIppi\"\n" | |
483 | "(eq? 'bitBlt (string->symbol \"bitBlt\")) \n" | |
484 | " ==> #f\n" | |
485 | "(eq? 'JollyWog\n" | |
486 | " (string->symbol\n" | |
487 | " (symbol->string 'JollyWog))) \n" | |
488 | " ==> #t\n" | |
489 | "(string=? \"K. Harper, M.D.\"\n" | |
490 | " (symbol->string\n" | |
491 | " (string->symbol \"K. Harper, M.D.\"))) \n" | |
492 | " ==> #t\n" | |
493 | "}\n" | |
494 | "@end format") | |
1bbd0b84 | 495 | #define FUNC_NAME s_scm_string_to_symbol |
0f2d19dd JB |
496 | { |
497 | SCM vcell; | |
498 | SCM answer; | |
499 | ||
3b3b36dd | 500 | SCM_VALIDATE_ROSTRING (1,s); |
0f2d19dd JB |
501 | vcell = scm_intern(SCM_ROCHARS(s), (scm_sizet)SCM_LENGTH(s)); |
502 | answer = SCM_CAR (vcell); | |
0f2d19dd JB |
503 | return answer; |
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 | ||
3b3b36dd | 527 | SCM_VALIDATE_ROSTRING (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 | ||
49bc24fe MD |
537 | vcell = scm_intern_obarray_soft (SCM_ROCHARS(s), |
538 | (scm_sizet)SCM_ROLENGTH(s), | |
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); |
49bc24fe MD |
560 | hval = scm_strhash (SCM_UCHARS (s), SCM_LENGTH (s), SCM_LENGTH(o)); |
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); |
49bc24fe MD |
597 | hval = scm_strhash (SCM_UCHARS (s), SCM_LENGTH (s), SCM_LENGTH(o)); |
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 JB |
702 | |
703 | static void | |
1bbd0b84 | 704 | msymbolize (SCM s) |
0f2d19dd JB |
705 | { |
706 | SCM string; | |
707 | string = scm_makfromstr (SCM_CHARS (s), SCM_LENGTH (s), SCM_SYMBOL_SLOTS); | |
708 | SCM_SETCHARS (s, SCM_CHARS (string)); | |
709 | SCM_SETLENGTH (s, SCM_LENGTH (s), scm_tc7_msymbol); | |
25d8012c MD |
710 | SCM_SETCDR (string, SCM_EOL); |
711 | SCM_SETCAR (string, SCM_EOL); | |
cf551a2b | 712 | SCM_SET_SYMBOL_PROPS (s, SCM_EOL); |
b2530d66 MD |
713 | /* If it's a tc7_ssymbol, it comes from scm_symhash */ |
714 | SCM_SYMBOL_HASH (s) = scm_strhash (SCM_UCHARS (s), | |
715 | (scm_sizet) SCM_LENGTH (s), | |
716 | SCM_LENGTH (scm_symhash)); | |
0f2d19dd JB |
717 | } |
718 | ||
719 | ||
3b3b36dd | 720 | SCM_DEFINE (scm_symbol_fref, "symbol-fref", 1, 0, 0, |
1bbd0b84 | 721 | (SCM s), |
b380b885 | 722 | "Return the contents of @var{symbol}'s @dfn{function slot}.") |
1bbd0b84 | 723 | #define FUNC_NAME s_scm_symbol_fref |
0f2d19dd | 724 | { |
3b3b36dd | 725 | SCM_VALIDATE_SYMBOL (1,s); |
0f2d19dd JB |
726 | SCM_DEFER_INTS; |
727 | if (SCM_TYP7(s) == scm_tc7_ssymbol) | |
728 | msymbolize (s); | |
729 | SCM_ALLOW_INTS; | |
730 | return SCM_SYMBOL_FUNC (s); | |
731 | } | |
1bbd0b84 | 732 | #undef FUNC_NAME |
0f2d19dd JB |
733 | |
734 | ||
3b3b36dd | 735 | SCM_DEFINE (scm_symbol_pref, "symbol-pref", 1, 0, 0, |
1bbd0b84 | 736 | (SCM s), |
b380b885 | 737 | "Return the @dfn{property list} currently associated with @var{symbol}.") |
1bbd0b84 | 738 | #define FUNC_NAME s_scm_symbol_pref |
0f2d19dd | 739 | { |
3b3b36dd | 740 | SCM_VALIDATE_SYMBOL (1,s); |
0f2d19dd JB |
741 | SCM_DEFER_INTS; |
742 | if (SCM_TYP7(s) == scm_tc7_ssymbol) | |
743 | msymbolize (s); | |
744 | SCM_ALLOW_INTS; | |
745 | return SCM_SYMBOL_PROPS (s); | |
746 | } | |
1bbd0b84 | 747 | #undef FUNC_NAME |
0f2d19dd JB |
748 | |
749 | ||
3b3b36dd | 750 | SCM_DEFINE (scm_symbol_fset_x, "symbol-fset!", 2, 0, 0, |
1bbd0b84 | 751 | (SCM s, SCM val), |
b380b885 | 752 | "Change the binding of @var{symbol}'s function slot.") |
1bbd0b84 | 753 | #define FUNC_NAME s_scm_symbol_fset_x |
0f2d19dd | 754 | { |
3b3b36dd | 755 | SCM_VALIDATE_SYMBOL (1,s); |
0f2d19dd JB |
756 | SCM_DEFER_INTS; |
757 | if (SCM_TYP7(s) == scm_tc7_ssymbol) | |
758 | msymbolize (s); | |
759 | SCM_ALLOW_INTS; | |
cf551a2b | 760 | SCM_SET_SYMBOL_FUNC (s, val); |
0f2d19dd JB |
761 | return SCM_UNSPECIFIED; |
762 | } | |
1bbd0b84 | 763 | #undef FUNC_NAME |
0f2d19dd JB |
764 | |
765 | ||
3b3b36dd | 766 | SCM_DEFINE (scm_symbol_pset_x, "symbol-pset!", 2, 0, 0, |
1bbd0b84 | 767 | (SCM s, SCM val), |
b380b885 | 768 | "Change the binding of @var{symbol}'s property slot.") |
1bbd0b84 | 769 | #define FUNC_NAME s_scm_symbol_pset_x |
0f2d19dd | 770 | { |
3b3b36dd | 771 | SCM_VALIDATE_SYMBOL (1,s); |
0f2d19dd JB |
772 | SCM_DEFER_INTS; |
773 | if (SCM_TYP7(s) == scm_tc7_ssymbol) | |
774 | msymbolize (s); | |
cf551a2b | 775 | SCM_SET_SYMBOL_PROPS (s, val); |
0f2d19dd JB |
776 | SCM_ALLOW_INTS; |
777 | return SCM_UNSPECIFIED; | |
778 | } | |
1bbd0b84 | 779 | #undef FUNC_NAME |
0f2d19dd JB |
780 | |
781 | ||
3b3b36dd | 782 | SCM_DEFINE (scm_symbol_hash, "symbol-hash", 1, 0, 0, |
1bbd0b84 | 783 | (SCM s), |
b380b885 MD |
784 | "Return the hash value derived from @var{symbol}'s name, i.e. the integer\n" |
785 | "index into @var{symbol}'s obarray at which it is stored.") | |
1bbd0b84 | 786 | #define FUNC_NAME s_scm_symbol_hash |
0f2d19dd | 787 | { |
3b3b36dd | 788 | SCM_VALIDATE_SYMBOL (1,s); |
b2530d66 MD |
789 | if (SCM_TYP7(s) == scm_tc7_ssymbol) |
790 | msymbolize (s); | |
cf551a2b | 791 | return SCM_MAKINUM (SCM_UNPACK (s) ^ SCM_SYMBOL_HASH (s)); |
0f2d19dd | 792 | } |
1bbd0b84 | 793 | #undef FUNC_NAME |
0f2d19dd JB |
794 | |
795 | ||
b2530d66 | 796 | static void |
1bbd0b84 | 797 | copy_and_prune_obarray (SCM from, SCM to) |
b2530d66 MD |
798 | { |
799 | int i; | |
800 | int length = SCM_LENGTH (from); | |
801 | for (i = 0; i < length; ++i) | |
802 | { | |
803 | SCM head = SCM_VELTS (from)[i]; /* GC protection */ | |
804 | SCM ls = head; | |
805 | SCM res = SCM_EOL; | |
806 | SCM *lloc = &res; | |
807 | while (SCM_NIMP (ls)) | |
808 | { | |
809 | if (!SCM_UNBNDP (SCM_CDAR (ls))) | |
810 | { | |
811 | *lloc = scm_cons (SCM_CAR (ls), SCM_EOL); | |
812 | lloc = SCM_CDRLOC (*lloc); | |
813 | } | |
814 | ls = SCM_CDR (ls); | |
815 | } | |
816 | SCM_VELTS (to)[i] = res; | |
817 | } | |
818 | } | |
819 | ||
820 | ||
3b3b36dd | 821 | SCM_DEFINE (scm_builtin_bindings, "builtin-bindings", 0, 0, 0, |
5ffe9968 | 822 | (), |
b380b885 MD |
823 | "Create and return a copy of the global symbol table, removing all\n" |
824 | "unbound symbols.") | |
1bbd0b84 | 825 | #define FUNC_NAME s_scm_builtin_bindings |
b2530d66 MD |
826 | { |
827 | int length = SCM_LENGTH (scm_symhash); | |
a8741caa | 828 | SCM obarray = scm_make_vector (SCM_MAKINUM (length), SCM_EOL); |
b2530d66 MD |
829 | copy_and_prune_obarray (scm_symhash, obarray); |
830 | return obarray; | |
831 | } | |
1bbd0b84 | 832 | #undef FUNC_NAME |
b2530d66 MD |
833 | |
834 | ||
3b3b36dd | 835 | SCM_DEFINE (scm_builtin_weak_bindings, "builtin-weak-bindings", 0, 0, 0, |
5ffe9968 | 836 | (), |
b380b885 | 837 | "") |
1bbd0b84 | 838 | #define FUNC_NAME s_scm_builtin_weak_bindings |
b2530d66 MD |
839 | { |
840 | int length = SCM_LENGTH (scm_weak_symhash); | |
841 | SCM obarray = scm_make_doubly_weak_hash_table (SCM_MAKINUM (length)); | |
842 | copy_and_prune_obarray (scm_weak_symhash, obarray); | |
843 | return obarray; | |
844 | } | |
1bbd0b84 | 845 | #undef FUNC_NAME |
b2530d66 | 846 | |
e1313058 MD |
847 | #define MAX_PREFIX_LENGTH 30 |
848 | ||
1ff4df7a | 849 | static int gensym_counter; |
e1313058 MD |
850 | |
851 | SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0, | |
852 | (SCM prefix), | |
853 | "Create a new symbol with name constructed from a prefix and a counter value.\n" | |
854 | "The string PREFIX can be specified as an optional argument.\n" | |
855 | "Default prefix is @code{g}. The counter is increased by 1 at each call.\n" | |
856 | "There is no provision for resetting the counter.") | |
1bbd0b84 | 857 | #define FUNC_NAME s_scm_gensym |
1ff4df7a | 858 | { |
e1313058 MD |
859 | char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN]; |
860 | char *name = buf; | |
861 | int len; | |
862 | if (SCM_UNBNDP (prefix)) | |
863 | { | |
864 | name[0] = 'g'; | |
865 | len = 1; | |
866 | } | |
1ff4df7a | 867 | else |
c64d02c5 | 868 | { |
e1313058 MD |
869 | SCM_VALIDATE_STRINGORSUBSTR (1, prefix); |
870 | len = SCM_ROLENGTH (prefix); | |
871 | if (len > MAX_PREFIX_LENGTH) | |
872 | name = SCM_MUST_MALLOC (MAX_PREFIX_LENGTH + SCM_INTBUFLEN); | |
873 | strncpy (name, SCM_ROCHARS (prefix), len); | |
c64d02c5 | 874 | } |
e1313058 MD |
875 | { |
876 | int n_digits = scm_iint2str (gensym_counter++, 10, &name[len]); | |
877 | SCM res = SCM_CAR (scm_intern (name, len + n_digits)); | |
878 | if (name != buf) | |
879 | scm_must_free (name); | |
880 | return res; | |
881 | } | |
882 | } | |
883 | #undef FUNC_NAME | |
1bbd0b84 | 884 | |
e1313058 MD |
885 | static int gentemp_counter; |
886 | ||
887 | SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0, | |
888 | (SCM prefix, SCM obarray), | |
889 | "Create a new symbol with a name unique in an obarray.\n" | |
890 | "The name is constructed from an optional string PREFIX and a counter\n" | |
891 | "value. The default prefix is @var{t}. The OBARRAY is specified as a\n" | |
892 | "second optional argument. Default is the system obarray where all\n" | |
893 | "normal symbols are interned. The counter is increased by 1 at each\n" | |
894 | "call. There is no provision for resetting the counter.") | |
895 | #define FUNC_NAME s_scm_gentemp | |
896 | { | |
897 | char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN]; | |
898 | char *name = buf; | |
899 | int len, n_digits; | |
900 | if (SCM_UNBNDP (prefix)) | |
901 | { | |
902 | name[0] = 't'; | |
903 | len = 1; | |
904 | } | |
905 | else | |
1ff4df7a | 906 | { |
e1313058 MD |
907 | SCM_VALIDATE_STRINGORSUBSTR (1, prefix); |
908 | len = SCM_ROLENGTH (prefix); | |
909 | if (len > MAX_PREFIX_LENGTH) | |
910 | name = SCM_MUST_MALLOC (MAX_PREFIX_LENGTH + SCM_INTBUFLEN); | |
911 | strncpy (name, SCM_ROCHARS (prefix), len); | |
1ff4df7a | 912 | } |
e1313058 MD |
913 | |
914 | if (SCM_UNBNDP (obarray)) | |
915 | obarray = scm_symhash; | |
1ff4df7a | 916 | else |
368cf54d | 917 | SCM_ASSERT ((SCM_VECTORP (obarray) || SCM_WVECTP (obarray)), |
1ff4df7a MD |
918 | obarray, |
919 | SCM_ARG2, | |
1bbd0b84 | 920 | FUNC_NAME); |
e1313058 MD |
921 | do |
922 | n_digits = scm_iint2str (gentemp_counter++, 10, &name[len]); | |
923 | while (!SCM_FALSEP (scm_intern_obarray_soft (name, | |
924 | len + n_digits, | |
925 | obarray, | |
926 | 1))); | |
927 | { | |
928 | SCM vcell = scm_intern_obarray_soft (name, | |
929 | len + n_digits, | |
930 | obarray, | |
931 | 0); | |
932 | if (name != buf) | |
933 | scm_must_free (name); | |
934 | return SCM_CAR (vcell); | |
935 | } | |
1ff4df7a | 936 | } |
1bbd0b84 | 937 | #undef FUNC_NAME |
1cc91f1b | 938 | |
0f2d19dd JB |
939 | void |
940 | scm_init_symbols () | |
0f2d19dd | 941 | { |
1ff4df7a | 942 | gensym_counter = 0; |
e1313058 | 943 | gentemp_counter = 0; |
a0599745 | 944 | #include "libguile/symbols.x" |
0f2d19dd | 945 | } |
89e00824 ML |
946 | |
947 | /* | |
948 | Local Variables: | |
949 | c-file-style: "gnu" | |
950 | End: | |
951 | */ |