* Eliminate use of low-level symbol property function.
[bpt/guile.git] / libguile / symbols.c
CommitLineData
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 81unsigned long
95c9e176 82scm_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
102int scm_symhash_dim = NUM_HASH_BUCKETS;
103
104
105/* scm_sym2vcell
106 * looks up the symbol in the symhash table.
107 */
1cc91f1b 108
0f2d19dd 109SCM
bccb33a9 110scm_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 177SCM
1bbd0b84 178scm_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 203SCM
1bbd0b84 204scm_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 237SCM
1bbd0b84 238scm_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 330SCM
1bbd0b84 331scm_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 337SCM
1bbd0b84 338scm_intern (const char *name,scm_sizet len)
0f2d19dd
JB
339{
340 return scm_intern_obarray (name, len, scm_symhash);
341}
342
1cc91f1b 343
0f2d19dd 344SCM
1bbd0b84 345scm_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 352SCM
1bbd0b84 353scm_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 */
384SCM
1bbd0b84 385scm_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
392SCM
1bbd0b84 393scm_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. */
411SCM
1bbd0b84 412scm_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 426SCM_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 436SCM_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 468SCM_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 508SCM_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 548SCM_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 585SCM_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 625SCM_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 644SCM_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 665SCM_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 685SCM_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
703static void
1bbd0b84 704msymbolize (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 720SCM_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 735SCM_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 750SCM_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 766SCM_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 782SCM_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 796static void
1bbd0b84 797copy_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 821SCM_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 835SCM_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 849static int gensym_counter;
e1313058
MD
850
851SCM_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
885static int gentemp_counter;
886
887SCM_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
939void
940scm_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*/