1 /* Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
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)
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.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
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.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
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.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
67 /* NUM_HASH_BUCKETS is the number of symbol scm_hash table buckets.
69 #define NUM_HASH_BUCKETS 137
79 scm_strhash (unsigned char *str
,scm_sizet len
,unsigned long n
)
84 unsigned long h
= 264 % n
;
86 h
= ((h
<< 8) + ((unsigned) (scm_downcase (str
[h
% len
])))) % n
;
94 h
= ((h
<< 8) + ((unsigned) (scm_downcase (str
[--i
])))) % n
;
99 int scm_symhash_dim
= NUM_HASH_BUCKETS
;
103 * looks up the symbol in the symhash table.
107 scm_sym2vcell (SCM sym
,SCM thunk
,SCM definep
)
111 SCM var
= scm_apply (thunk
, sym
, scm_cons(definep
, scm_listofnull
));
113 if (var
== SCM_BOOL_F
)
117 if (SCM_IMP(var
) || !SCM_VARIABLEP (var
))
118 scm_wta (sym
, "strangely interned symbol? ", "");
119 return SCM_VARVCELL (var
);
127 scm_sizet scm_hash
= scm_strhash (SCM_UCHARS (sym
), (scm_sizet
) SCM_LENGTH (sym
),
128 (unsigned long) scm_symhash_dim
);
131 for (lsym
= SCM_VELTS (scm_symhash
)[scm_hash
]; SCM_NIMP (lsym
); lsym
= SCM_CDR (lsym
))
134 if (SCM_CAR (z
) == sym
)
141 for (lsym
= *(lsymp
= &SCM_VELTS (scm_weak_symhash
)[scm_hash
]);
143 lsym
= *(lsymp
= SCM_CDRLOC (lsym
)))
146 if (SCM_CAR (z
) == sym
)
148 if (SCM_NFALSEP (definep
))
150 /* Move handle from scm_weak_symhash to scm_symhash. */
151 *lsymp
= SCM_CDR (lsym
);
152 SCM_SETCDR (lsym
, SCM_VELTS(scm_symhash
)[scm_hash
]);
153 SCM_VELTS(scm_symhash
)[scm_hash
] = lsym
;
160 return scm_wta (sym
, "uninterned symbol? ", "");
165 * looks up the symbol in an arbitrary obarray.
169 scm_sym2ovcell_soft (SCM sym
, SCM obarray
)
174 scm_hash
= scm_strhash (SCM_UCHARS (sym
),
175 (scm_sizet
) SCM_LENGTH (sym
),
176 SCM_LENGTH (obarray
));
178 for (lsym
= SCM_VELTS (obarray
)[scm_hash
];
180 lsym
= SCM_CDR (lsym
))
183 if (SCM_CAR (z
) == sym
)
195 scm_sym2ovcell (SCM sym
, SCM obarray
)
198 answer
= scm_sym2ovcell_soft (sym
, obarray
);
199 if (answer
!= SCM_BOOL_F
)
201 scm_wta (sym
, "uninterned symbol? ", "");
202 return SCM_UNSPECIFIED
; /* not reached */
205 /* Intern a symbol whose name is the LEN characters at NAME in OBARRAY.
207 OBARRAY should be a vector of lists, indexed by the name's hash
208 value, modulo OBARRAY's length. Each list has the form
209 ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the
210 value associated with that symbol (in the current module? in the
213 To "intern" a symbol means: if OBARRAY already contains a symbol by
214 that name, return its (SYMBOL . VALUE) pair; otherwise, create a
215 new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the
216 appropriate list of the OBARRAY, and return the pair.
218 If softness is non-zero, don't create a symbol if it isn't already
219 in OBARRAY; instead, just return #f.
221 If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and
222 return (SYMBOL . SCM_UNDEFINED).
224 If OBARRAY is scm_symhash, and that doesn't contain the symbol,
225 check scm_weak_symhash instead. */
229 scm_intern_obarray_soft (const char *name
,scm_sizet len
,SCM obarray
,int softness
)
233 register scm_sizet i
;
234 register unsigned char *tmp
;
240 tmp
= (unsigned char *) name
;
242 if (obarray
== SCM_BOOL_F
)
244 scm_hash
= scm_strhash (tmp
, i
, 1019);
245 goto uninterned_symbol
;
248 scm_hash
= scm_strhash (tmp
, i
, SCM_LENGTH(obarray
));
250 /* softness == -1 used to mean that it was known that the symbol
251 wasn't already in the obarray. I don't think there are any
252 callers that use that case any more, but just in case...
258 for (lsym
= SCM_VELTS (obarray
)[scm_hash
]; SCM_NIMP (lsym
); lsym
= SCM_CDR (lsym
))
262 tmp
= SCM_UCHARS (z
);
263 if (SCM_LENGTH (z
) != len
)
266 if (((unsigned char *) name
)[i
] != tmp
[i
])
277 if (obarray
== scm_symhash
)
279 obarray
= scm_weak_symhash
;
280 goto retry_new_obarray
;
290 lsym
= scm_makfromstr (name
, len
, SCM_SYMBOL_SLOTS
);
292 SCM_SETLENGTH (lsym
, (long) len
, scm_tc7_msymbol
);
293 SCM_SYMBOL_HASH (lsym
) = scm_hash
;
294 SCM_SYMBOL_PROPS (lsym
) = SCM_EOL
;
295 if (obarray
== SCM_BOOL_F
)
299 SCM_NEWCELL (answer
);
301 SCM_SETCAR (answer
, lsym
);
302 SCM_SETCDR (answer
, SCM_UNDEFINED
);
313 SCM_SETCAR (a
, lsym
);
314 SCM_SETCDR (a
, SCM_UNDEFINED
);
316 SCM_SETCDR (b
, SCM_VELTS(obarray
)[scm_hash
]);
317 SCM_VELTS(obarray
)[scm_hash
] = b
;
325 scm_intern_obarray (const char *name
,scm_sizet len
,SCM obarray
)
327 return scm_intern_obarray_soft (name
, len
, obarray
, 0);
332 scm_intern (const char *name
,scm_sizet len
)
334 return scm_intern_obarray (name
, len
, scm_symhash
);
339 scm_intern0 (const char * name
)
341 return scm_intern (name
, strlen (name
));
345 /* Intern the symbol named NAME in scm_symhash, NAME is null-terminated. */
347 scm_sysintern0_no_module_lookup (const char *name
)
351 easy_answer
= scm_intern_obarray_soft (name
, strlen (name
), scm_symhash
, 1);
352 if (SCM_NIMP (easy_answer
))
360 scm_sizet len
= strlen (name
);
361 register unsigned char *tmp
= (unsigned char *) name
;
362 scm_sizet scm_hash
= scm_strhash (tmp
, len
, (unsigned long) scm_symhash_dim
);
364 SCM_SETLENGTH (lsym
, (long) len
, scm_tc7_ssymbol
);
365 SCM_SETCHARS (lsym
, name
);
366 lsym
= scm_cons (lsym
, SCM_UNDEFINED
);
367 SCM_VELTS (scm_symhash
)[scm_hash
] = scm_cons (lsym
, SCM_VELTS (scm_symhash
)[scm_hash
]);
374 /* Is it safe to access SCM_TOP_LEVEL_LOOKUP_CLOSURE_VAR?
376 int scm_can_use_top_level_lookup_closure_var
;
378 /* Intern the symbol named NAME in scm_symhash, and give it the value
379 VAL. NAME is null-terminated. Use the current top_level lookup
380 closure to give NAME its value.
383 scm_sysintern (const char *name
, SCM val
)
385 SCM vcell
= scm_sysintern0 (name
);
386 SCM_SETCDR (vcell
, val
);
391 scm_sysintern0 (const char *name
)
394 if (scm_can_use_top_level_lookup_closure_var
&&
395 SCM_NIMP (lookup_proc
= SCM_CDR (scm_top_level_lookup_closure_var
)))
397 SCM sym
= SCM_CAR (scm_intern0 (name
));
398 SCM vcell
= scm_sym2vcell (sym
, lookup_proc
, SCM_BOOL_T
);
399 if (vcell
== SCM_BOOL_F
)
400 scm_misc_error ("sysintern0", "can't define variable", sym
);
404 return scm_sysintern0_no_module_lookup (name
);
407 /* Lookup the value of the symbol named by the nul-terminated string
408 NAME in the current module. */
410 scm_symbol_value0 (const char *name
)
412 /* This looks silly - we look up the symbol twice. But it is in
413 fact necessary given the current module system because the module
414 lookup closures are written in scheme which needs real symbols. */
415 SCM symbol
= scm_intern_obarray_soft (name
, strlen (name
), scm_symhash
, 0);
416 SCM vcell
= scm_sym2vcell (SCM_CAR (symbol
),
417 SCM_CDR (scm_top_level_lookup_closure_var
),
419 if (SCM_FALSEP (vcell
))
420 return SCM_UNDEFINED
;
421 return SCM_CDR (vcell
);
424 SCM_DEFINE (scm_symbol_p
, "symbol?", 1, 0, 0,
426 "Returns @t{#t} if @var{obj} is a symbol, otherwise returns @t{#f}. (r5rs)")
427 #define FUNC_NAME s_scm_symbol_p
429 if SCM_IMP(obj
) return SCM_BOOL_F
;
430 return SCM_BOOL(SCM_SYMBOLP(obj
));
434 SCM_DEFINE (scm_symbol_to_string
, "symbol->string", 1, 0, 0,
436 "Returns the name of @var{symbol} as a string. If the symbol was part of\n"
437 "an object returned as the value of a literal expression\n"
438 "(section @pxref{Literal expressions}) or by a call to the @samp{read} procedure,\n"
439 "and its name contains alphabetic characters, then the string returned\n"
440 "will contain characters in the implementation's preferred standard\n"
441 "case---some implementations will prefer upper case, others lower case.\n"
442 "If the symbol was returned by @samp{string->symbol}, the case of\n"
443 "characters in the string returned will be the same as the case in the\n"
444 "string that was passed to @samp{string->symbol}. It is an error\n"
445 "to apply mutation procedures like @code{string-set!} to strings returned\n"
446 "by this procedure. (r5rs)\n\n"
447 "The following examples assume that the implementation's standard case is\n"
450 "@t{(symbol->string 'flying-fish) \n"
451 " ==> \"flying-fish\"\n"
452 "(symbol->string 'Martin) ==> \"martin\"\n"
454 " (string->symbol "Malvina
")) \n"
458 #define FUNC_NAME s_scm_symbol_to_string
460 SCM_VALIDATE_SYMBOL (1,s
);
461 return scm_makfromstr(SCM_CHARS(s
), (scm_sizet
)SCM_LENGTH(s
), 0);
466 SCM_DEFINE (scm_string_to_symbol
, "string->symbol", 1, 0, 0,
468 "Returns the symbol whose name is @var{string}. This procedure can\n"
469 "create symbols with names containing special characters or letters in\n"
470 "the non-standard case, but it is usually a bad idea to create such\n"
471 "symbols because in some implementations of Scheme they cannot be read as\n"
472 "themselves. See @samp{symbol->string}.\n\n"
473 "The following examples assume that the implementation's standard case is\n"
476 "@t{(eq? 'mISSISSIppi 'mississippi) \n"
478 "(string->symbol \"mISSISSIppi\") \n"
480 " @r{}the symbol with name \"mISSISSIppi\"\n"
481 "(eq? 'bitBlt (string->symbol \"bitBlt\")) \n"
485 " (symbol->string 'JollyWog))) \n"
487 "(string=? \"K. Harper, M.D.\"\n"
489 " (string->symbol \"K. Harper, M.D.\"))) \n"
493 #define FUNC_NAME s_scm_string_to_symbol
498 SCM_VALIDATE_ROSTRING (1,s
);
499 vcell
= scm_intern(SCM_ROCHARS(s
), (scm_sizet
)SCM_LENGTH(s
));
500 answer
= SCM_CAR (vcell
);
506 SCM_DEFINE (scm_string_to_obarray_symbol
, "string->obarray-symbol", 2, 1, 0,
507 (SCM o
, SCM s
, SCM softp
),
508 "Intern a new symbol in @var{obarray}, a symbol table, with name\n"
510 "If @var{obarray} is @code{#f}, use the default system symbol table. If\n"
511 "@var{obarray} is @code{#t}, the symbol should not be interned in any\n"
512 "symbol table; merely return the pair (@var{symbol}\n"
513 ". @var{#<undefined>}).\n\n"
514 "The @var{soft?} argument determines whether new symbol table entries\n"
515 "should be created when the specified symbol is not already present in\n"
516 "@var{obarray}. If @var{soft?} is specified and is a true value, then\n"
517 "new entries should not be added for symbols not already present in the\n"
518 "table; instead, simply return @code{#f}.")
519 #define FUNC_NAME s_scm_string_to_obarray_symbol
525 SCM_VALIDATE_ROSTRING (2,s
);
526 SCM_ASSERT((o
== SCM_BOOL_F
)
529 o
, SCM_ARG1
, FUNC_NAME
);
531 softness
= ((softp
!= SCM_UNDEFINED
) && (softp
!= SCM_BOOL_F
));
532 /* iron out some screwy calling conventions */
535 else if (o
== SCM_BOOL_T
)
538 vcell
= scm_intern_obarray_soft (SCM_ROCHARS(s
),
539 (scm_sizet
)SCM_ROLENGTH(s
),
542 if (vcell
== SCM_BOOL_F
)
544 answer
= SCM_CAR (vcell
);
549 SCM_DEFINE (scm_intern_symbol
, "intern-symbol", 2, 0, 0,
551 "Add a new symbol to @var{obarray} with name @var{string}, bound to an\n"
552 "unspecified initial value. The symbol table is not modified if a symbol\n"
553 "with this name is already present.")
554 #define FUNC_NAME s_scm_intern_symbol
557 SCM_VALIDATE_SYMBOL (2,s
);
560 SCM_VALIDATE_VECTOR (1,o
);
561 hval
= scm_strhash (SCM_UCHARS (s
), SCM_LENGTH (s
), SCM_LENGTH(o
));
562 /* If the symbol is already interned, simply return. */
567 for (lsym
= SCM_VELTS (o
)[hval
];
569 lsym
= SCM_CDR (lsym
))
571 sym
= SCM_CAR (lsym
);
572 if (SCM_CAR (sym
) == s
)
575 return SCM_UNSPECIFIED
;
578 SCM_VELTS (o
)[hval
] =
579 scm_acons (s
, SCM_UNDEFINED
, SCM_VELTS (o
)[hval
]);
582 return SCM_UNSPECIFIED
;
586 SCM_DEFINE (scm_unintern_symbol
, "unintern-symbol", 2, 0, 0,
588 "Remove the symbol with name @var{string} from @var{obarray}. This\n"
589 "function returns @code{#t} if the symbol was present and @code{#f}\n"
591 #define FUNC_NAME s_scm_unintern_symbol
594 SCM_VALIDATE_SYMBOL (2,s
);
597 SCM_VALIDATE_VECTOR (1,o
);
598 hval
= scm_strhash (SCM_UCHARS (s
), SCM_LENGTH (s
), SCM_LENGTH(o
));
604 for (lsym
= SCM_VELTS (o
)[hval
], lsym_follow
= SCM_BOOL_F
;
606 lsym_follow
= lsym
, lsym
= SCM_CDR (lsym
))
608 sym
= SCM_CAR (lsym
);
609 if (SCM_CAR (sym
) == s
)
611 /* Found the symbol to unintern. */
612 if (lsym_follow
== SCM_BOOL_F
)
613 SCM_VELTS(o
)[hval
] = lsym
;
615 SCM_SETCDR (lsym_follow
, SCM_CDR(lsym
));
626 SCM_DEFINE (scm_symbol_binding
, "symbol-binding", 2, 0, 0,
628 "Look up in @var{obarray} the symbol whose name is @var{string}, and\n"
629 "return the value to which it is bound. If @var{obarray} is @code{#f},\n"
630 "use the global symbol table. If @var{string} is not interned in\n"
631 "@var{obarray}, an error is signalled.")
632 #define FUNC_NAME s_scm_symbol_binding
635 SCM_VALIDATE_SYMBOL (2,s
);
638 SCM_VALIDATE_VECTOR (1,o
);
639 vcell
= scm_sym2ovcell (s
, o
);
640 return SCM_CDR(vcell
);
645 SCM_DEFINE (scm_symbol_interned_p
, "symbol-interned?", 2, 0, 0,
647 "Return @var{#t} if @var{obarray} contains a symbol with name\n"
648 "@var{string}, and @var{#f} otherwise.")
649 #define FUNC_NAME s_scm_symbol_interned_p
652 SCM_VALIDATE_SYMBOL (2,s
);
655 SCM_VALIDATE_VECTOR (1,o
);
656 vcell
= scm_sym2ovcell_soft (s
, o
);
657 if (SCM_IMP(vcell
) && (o
== scm_symhash
))
658 vcell
= scm_sym2ovcell_soft (s
, scm_weak_symhash
);
659 return (SCM_NIMP(vcell
)
666 SCM_DEFINE (scm_symbol_bound_p
, "symbol-bound?", 2, 0, 0,
668 "Return @var{#t} if @var{obarray} contains a symbol with name\n"
669 "@var{string} bound to a defined value. This differs from\n"
670 "@var{symbol-bound?} in that the mere mention of a symbol usually causes\n"
671 "it to be interned; @code{symbol-bound?} determines whether a symbol has\n"
672 "been given any meaningful value.")
673 #define FUNC_NAME s_scm_symbol_bound_p
676 SCM_VALIDATE_SYMBOL (2,s
);
679 SCM_VALIDATE_VECTOR (1,o
);
680 vcell
= scm_sym2ovcell_soft (s
, o
);
681 return (( SCM_NIMP(vcell
)
682 && (SCM_CDR(vcell
) != SCM_UNDEFINED
))
689 SCM_DEFINE (scm_symbol_set_x
, "symbol-set!", 3, 0, 0,
690 (SCM o
, SCM s
, SCM v
),
691 "Find the symbol in @var{obarray} whose name is @var{string}, and rebind\n"
692 "it to @var{value}. An error is signalled if @var{string} is not present\n"
694 #define FUNC_NAME s_scm_symbol_set_x
697 SCM_VALIDATE_SYMBOL (2,s
);
700 SCM_VALIDATE_VECTOR (1,o
);
701 vcell
= scm_sym2ovcell (s
, o
);
702 SCM_SETCDR (vcell
, v
);
703 return SCM_UNSPECIFIED
;
711 string
= scm_makfromstr (SCM_CHARS (s
), SCM_LENGTH (s
), SCM_SYMBOL_SLOTS
);
712 SCM_SETCHARS (s
, SCM_CHARS (string
));
713 SCM_SETLENGTH (s
, SCM_LENGTH (s
), scm_tc7_msymbol
);
714 SCM_SETCDR (string
, SCM_EOL
);
715 SCM_SETCAR (string
, SCM_EOL
);
716 SCM_SYMBOL_PROPS (s
) = SCM_EOL
;
717 /* If it's a tc7_ssymbol, it comes from scm_symhash */
718 SCM_SYMBOL_HASH (s
) = scm_strhash (SCM_UCHARS (s
),
719 (scm_sizet
) SCM_LENGTH (s
),
720 SCM_LENGTH (scm_symhash
));
724 SCM_DEFINE (scm_symbol_fref
, "symbol-fref", 1, 0, 0,
726 "Return the contents of @var{symbol}'s @dfn{function slot}.")
727 #define FUNC_NAME s_scm_symbol_fref
729 SCM_VALIDATE_SYMBOL (1,s
);
731 if (SCM_TYP7(s
) == scm_tc7_ssymbol
)
734 return SCM_SYMBOL_FUNC (s
);
739 SCM_DEFINE (scm_symbol_pref
, "symbol-pref", 1, 0, 0,
741 "Return the @dfn{property list} currently associated with @var{symbol}.")
742 #define FUNC_NAME s_scm_symbol_pref
744 SCM_VALIDATE_SYMBOL (1,s
);
746 if (SCM_TYP7(s
) == scm_tc7_ssymbol
)
749 return SCM_SYMBOL_PROPS (s
);
754 SCM_DEFINE (scm_symbol_fset_x
, "symbol-fset!", 2, 0, 0,
756 "Change the binding of @var{symbol}'s function slot.")
757 #define FUNC_NAME s_scm_symbol_fset_x
759 SCM_VALIDATE_SYMBOL (1,s
);
761 if (SCM_TYP7(s
) == scm_tc7_ssymbol
)
764 SCM_SYMBOL_FUNC (s
) = val
;
765 return SCM_UNSPECIFIED
;
770 SCM_DEFINE (scm_symbol_pset_x
, "symbol-pset!", 2, 0, 0,
772 "Change the binding of @var{symbol}'s property slot.")
773 #define FUNC_NAME s_scm_symbol_pset_x
775 SCM_VALIDATE_SYMBOL (1,s
);
777 if (SCM_TYP7(s
) == scm_tc7_ssymbol
)
779 SCM_SYMBOL_PROPS (s
) = val
;
781 return SCM_UNSPECIFIED
;
786 SCM_DEFINE (scm_symbol_hash
, "symbol-hash", 1, 0, 0,
788 "Return the hash value derived from @var{symbol}'s name, i.e. the integer\n"
789 "index into @var{symbol}'s obarray at which it is stored.")
790 #define FUNC_NAME s_scm_symbol_hash
792 SCM_VALIDATE_SYMBOL (1,s
);
793 if (SCM_TYP7(s
) == scm_tc7_ssymbol
)
795 return SCM_MAKINUM ((unsigned long)s
^ SCM_SYMBOL_HASH (s
));
801 copy_and_prune_obarray (SCM from
, SCM to
)
804 int length
= SCM_LENGTH (from
);
805 for (i
= 0; i
< length
; ++i
)
807 SCM head
= SCM_VELTS (from
)[i
]; /* GC protection */
811 while (SCM_NIMP (ls
))
813 if (!SCM_UNBNDP (SCM_CDAR (ls
)))
815 *lloc
= scm_cons (SCM_CAR (ls
), SCM_EOL
);
816 lloc
= SCM_CDRLOC (*lloc
);
820 SCM_VELTS (to
)[i
] = res
;
825 SCM_DEFINE (scm_builtin_bindings
, "builtin-bindings", 0, 0, 0,
827 "Create and return a copy of the global symbol table, removing all\n"
829 #define FUNC_NAME s_scm_builtin_bindings
831 int length
= SCM_LENGTH (scm_symhash
);
832 SCM obarray
= scm_make_vector (SCM_MAKINUM (length
), SCM_EOL
);
833 copy_and_prune_obarray (scm_symhash
, obarray
);
839 SCM_DEFINE (scm_builtin_weak_bindings
, "builtin-weak-bindings", 0, 0, 0,
842 #define FUNC_NAME s_scm_builtin_weak_bindings
844 int length
= SCM_LENGTH (scm_weak_symhash
);
845 SCM obarray
= scm_make_doubly_weak_hash_table (SCM_MAKINUM (length
));
846 copy_and_prune_obarray (scm_weak_symhash
, obarray
);
851 static int gensym_counter
;
852 static SCM gensym_prefix
;
854 /* :FIXME:OPTIMIZE */
855 SCM_DEFINE (scm_gensym
, "gensym", 0, 2, 0,
856 (SCM name
, SCM obarray
),
857 "Create a new, unique symbol in @var{obarray}, using the global symbol\n"
858 "table by default. If @var{name} is specified, it should be used as a\n"
859 "prefix for the new symbol's name. The default prefix is @code{%%gensym}.")
860 #define FUNC_NAME s_scm_gensym
863 if (SCM_UNBNDP (name
))
864 name
= gensym_prefix
;
866 SCM_VALIDATE_ROSTRING (1,name
);
869 if (SCM_UNBNDP (obarray
))
871 obarray
= SCM_BOOL_F
;
875 SCM_ASSERT ((SCM_VECTORP (obarray
) || SCM_WVECTP (obarray
)),
879 while (scm_string_to_obarray_symbol (obarray
, new, SCM_BOOL_T
)
882 new = scm_string_append
884 scm_number_to_string (SCM_MAKINUM (gensym_counter
++),
887 return scm_string_to_obarray_symbol (obarray
, new, SCM_BOOL_F
);
895 gensym_prefix
= scm_permanent_object (scm_makfrom0str ("%%gensym"));