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 */
66 /* NUM_HASH_BUCKETS is the number of symbol scm_hash table buckets.
68 #define NUM_HASH_BUCKETS 137
78 scm_strhash (unsigned char *str
,scm_sizet len
,unsigned long n
)
83 unsigned long h
= 264 % n
;
85 h
= ((h
<< 8) + ((unsigned) (scm_downcase (str
[h
% len
])))) % n
;
93 h
= ((h
<< 8) + ((unsigned) (scm_downcase (str
[--i
])))) % n
;
98 int scm_symhash_dim
= NUM_HASH_BUCKETS
;
102 * looks up the symbol in the symhash table.
106 scm_sym2vcell (SCM sym
,SCM thunk
,SCM definep
)
110 SCM var
= scm_apply (thunk
, sym
, scm_cons(definep
, scm_listofnull
));
112 if (var
== SCM_BOOL_F
)
116 if (SCM_IMP(var
) || !SCM_VARIABLEP (var
))
117 scm_wta (sym
, "strangely interned symbol? ", "");
118 return SCM_VARVCELL (var
);
126 scm_sizet scm_hash
= scm_strhash (SCM_UCHARS (sym
), (scm_sizet
) SCM_LENGTH (sym
),
127 (unsigned long) scm_symhash_dim
);
130 for (lsym
= SCM_VELTS (scm_symhash
)[scm_hash
]; SCM_NIMP (lsym
); lsym
= SCM_CDR (lsym
))
133 if (SCM_CAR (z
) == sym
)
140 for (lsym
= *(lsymp
= &SCM_VELTS (scm_weak_symhash
)[scm_hash
]);
142 lsym
= *(lsymp
= SCM_CDRLOC (lsym
)))
145 if (SCM_CAR (z
) == sym
)
147 if (SCM_NFALSEP (definep
))
149 /* Move handle from scm_weak_symhash to scm_symhash. */
150 *lsymp
= SCM_CDR (lsym
);
151 SCM_SETCDR (lsym
, SCM_VELTS(scm_symhash
)[scm_hash
]);
152 SCM_VELTS(scm_symhash
)[scm_hash
] = lsym
;
159 return scm_wta (sym
, "uninterned symbol? ", "");
164 * looks up the symbol in an arbitrary obarray.
168 scm_sym2ovcell_soft (SCM sym
, SCM obarray
)
173 scm_hash
= scm_strhash (SCM_UCHARS (sym
),
174 (scm_sizet
) SCM_LENGTH (sym
),
175 SCM_LENGTH (obarray
));
177 for (lsym
= SCM_VELTS (obarray
)[scm_hash
];
179 lsym
= SCM_CDR (lsym
))
182 if (SCM_CAR (z
) == sym
)
194 scm_sym2ovcell (SCM sym
, SCM obarray
)
197 answer
= scm_sym2ovcell_soft (sym
, obarray
);
198 if (answer
!= SCM_BOOL_F
)
200 scm_wta (sym
, "uninterned symbol? ", "");
201 return SCM_UNSPECIFIED
; /* not reached */
204 /* Intern a symbol whose name is the LEN characters at NAME in OBARRAY.
206 OBARRAY should be a vector of lists, indexed by the name's hash
207 value, modulo OBARRAY's length. Each list has the form
208 ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the
209 value associated with that symbol (in the current module? in the
212 To "intern" a symbol means: if OBARRAY already contains a symbol by
213 that name, return its (SYMBOL . VALUE) pair; otherwise, create a
214 new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the
215 appropriate list of the OBARRAY, and return the pair.
217 If softness is non-zero, don't create a symbol if it isn't already
218 in OBARRAY; instead, just return #f.
220 If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and
221 return (SYMBOL . SCM_UNDEFINED).
223 If OBARRAY is scm_symhash, and that doesn't contain the symbol,
224 check scm_weak_symhash instead. */
228 scm_intern_obarray_soft (const char *name
,scm_sizet len
,SCM obarray
,int softness
)
232 register scm_sizet i
;
233 register unsigned char *tmp
;
239 tmp
= (unsigned char *) name
;
241 if (obarray
== SCM_BOOL_F
)
243 scm_hash
= scm_strhash (tmp
, i
, 1019);
244 goto uninterned_symbol
;
247 scm_hash
= scm_strhash (tmp
, i
, SCM_LENGTH(obarray
));
249 /* softness == -1 used to mean that it was known that the symbol
250 wasn't already in the obarray. I don't think there are any
251 callers that use that case any more, but just in case...
257 for (lsym
= SCM_VELTS (obarray
)[scm_hash
]; SCM_NIMP (lsym
); lsym
= SCM_CDR (lsym
))
261 tmp
= SCM_UCHARS (z
);
262 if (SCM_LENGTH (z
) != len
)
265 if (((unsigned char *) name
)[i
] != tmp
[i
])
276 if (obarray
== scm_symhash
)
278 obarray
= scm_weak_symhash
;
279 goto retry_new_obarray
;
289 lsym
= scm_makfromstr (name
, len
, SCM_SYMBOL_SLOTS
);
291 SCM_SETLENGTH (lsym
, (long) len
, scm_tc7_msymbol
);
292 SCM_SYMBOL_HASH (lsym
) = scm_hash
;
293 SCM_SYMBOL_PROPS (lsym
) = SCM_EOL
;
294 if (obarray
== SCM_BOOL_F
)
298 SCM_NEWCELL (answer
);
300 SCM_SETCAR (answer
, lsym
);
301 SCM_SETCDR (answer
, SCM_UNDEFINED
);
312 SCM_SETCAR (a
, lsym
);
313 SCM_SETCDR (a
, SCM_UNDEFINED
);
315 SCM_SETCDR (b
, SCM_VELTS(obarray
)[scm_hash
]);
316 SCM_VELTS(obarray
)[scm_hash
] = b
;
324 scm_intern_obarray (const char *name
,scm_sizet len
,SCM obarray
)
326 return scm_intern_obarray_soft (name
, len
, obarray
, 0);
331 scm_intern (const char *name
,scm_sizet len
)
333 return scm_intern_obarray (name
, len
, scm_symhash
);
338 scm_intern0 (const char * name
)
340 return scm_intern (name
, strlen (name
));
344 /* Intern the symbol named NAME in scm_symhash, NAME is null-terminated. */
346 scm_sysintern0_no_module_lookup (const char *name
)
350 easy_answer
= scm_intern_obarray_soft (name
, strlen (name
), scm_symhash
, 1);
351 if (SCM_NIMP (easy_answer
))
359 scm_sizet len
= strlen (name
);
360 register unsigned char *tmp
= (unsigned char *) name
;
361 scm_sizet scm_hash
= scm_strhash (tmp
, len
, (unsigned long) scm_symhash_dim
);
363 SCM_SETLENGTH (lsym
, (long) len
, scm_tc7_ssymbol
);
364 SCM_SETCHARS (lsym
, name
);
365 lsym
= scm_cons (lsym
, SCM_UNDEFINED
);
366 SCM_VELTS (scm_symhash
)[scm_hash
] = scm_cons (lsym
, SCM_VELTS (scm_symhash
)[scm_hash
]);
373 /* Is it safe to access SCM_TOP_LEVEL_LOOKUP_CLOSURE_VAR?
375 int scm_can_use_top_level_lookup_closure_var
;
377 /* Intern the symbol named NAME in scm_symhash, and give it the value
378 VAL. NAME is null-terminated. Use the current top_level lookup
379 closure to give NAME its value.
382 scm_sysintern (const char *name
, SCM val
)
384 SCM vcell
= scm_sysintern0 (name
);
385 SCM_SETCDR (vcell
, val
);
390 scm_sysintern0 (const char *name
)
393 if (scm_can_use_top_level_lookup_closure_var
&&
394 SCM_NIMP (lookup_proc
= SCM_CDR (scm_top_level_lookup_closure_var
)))
396 SCM sym
= SCM_CAR (scm_intern0 (name
));
397 SCM vcell
= scm_sym2vcell (sym
, lookup_proc
, SCM_BOOL_T
);
398 if (vcell
== SCM_BOOL_F
)
399 scm_misc_error ("sysintern0", "can't define variable", sym
);
403 return scm_sysintern0_no_module_lookup (name
);
406 /* Lookup the value of the symbol named by the nul-terminated string
407 NAME in the current module. */
409 scm_symbol_value0 (const char *name
)
411 /* This looks silly - we look up the symbol twice. But it is in
412 fact necessary given the current module system because the module
413 lookup closures are written in scheme which needs real symbols. */
414 SCM symbol
= scm_intern_obarray_soft (name
, strlen (name
), scm_symhash
, 0);
415 SCM vcell
= scm_sym2vcell (SCM_CAR (symbol
),
416 SCM_CDR (scm_top_level_lookup_closure_var
),
418 if (SCM_FALSEP (vcell
))
419 return SCM_UNDEFINED
;
420 return SCM_CDR (vcell
);
423 SCM_DEFINE (scm_symbol_p
, "symbol?", 1, 0, 0,
425 "Returns @t{#t} if @var{obj} is a symbol, otherwise returns @t{#f}. (r5rs)")
426 #define FUNC_NAME s_scm_symbol_p
428 if SCM_IMP(obj
) return SCM_BOOL_F
;
429 return SCM_BOOL(SCM_SYMBOLP(obj
));
433 SCM_DEFINE (scm_symbol_to_string
, "symbol->string", 1, 0, 0,
435 "Returns the name of @var{symbol} as a string. If the symbol was part of\n"
436 "an object returned as the value of a literal expression\n"
437 "(section @pxref{Literal expressions}) or by a call to the @samp{read} procedure,\n"
438 "and its name contains alphabetic characters, then the string returned\n"
439 "will contain characters in the implementation's preferred standard\n"
440 "case---some implementations will prefer upper case, others lower case.\n"
441 "If the symbol was returned by @samp{string->symbol}, the case of\n"
442 "characters in the string returned will be the same as the case in the\n"
443 "string that was passed to @samp{string->symbol}. It is an error\n"
444 "to apply mutation procedures like @code{string-set!} to strings returned\n"
445 "by this procedure. (r5rs)\n\n"
446 "The following examples assume that the implementation's standard case is\n"
449 "@t{(symbol->string 'flying-fish) \n"
450 " ==> \"flying-fish\"\n"
451 "(symbol->string 'Martin) ==> \"martin\"\n"
453 " (string->symbol "Malvina
")) \n"
457 #define FUNC_NAME s_scm_symbol_to_string
459 SCM_VALIDATE_SYMBOL (1,s
);
460 return scm_makfromstr(SCM_CHARS(s
), (scm_sizet
)SCM_LENGTH(s
), 0);
465 SCM_DEFINE (scm_string_to_symbol
, "string->symbol", 1, 0, 0,
467 "Returns the symbol whose name is @var{string}. This procedure can\n"
468 "create symbols with names containing special characters or letters in\n"
469 "the non-standard case, but it is usually a bad idea to create such\n"
470 "symbols because in some implementations of Scheme they cannot be read as\n"
471 "themselves. See @samp{symbol->string}.\n\n"
472 "The following examples assume that the implementation's standard case is\n"
475 "@t{(eq? 'mISSISSIppi 'mississippi) \n"
477 "(string->symbol \"mISSISSIppi\") \n"
479 " @r{}the symbol with name \"mISSISSIppi\"\n"
480 "(eq? 'bitBlt (string->symbol \"bitBlt\")) \n"
484 " (symbol->string 'JollyWog))) \n"
486 "(string=? \"K. Harper, M.D.\"\n"
488 " (string->symbol \"K. Harper, M.D.\"))) \n"
492 #define FUNC_NAME s_scm_string_to_symbol
497 SCM_VALIDATE_ROSTRING (1,s
);
498 vcell
= scm_intern(SCM_ROCHARS(s
), (scm_sizet
)SCM_LENGTH(s
));
499 answer
= SCM_CAR (vcell
);
505 SCM_DEFINE (scm_string_to_obarray_symbol
, "string->obarray-symbol", 2, 1, 0,
506 (SCM o
, SCM s
, SCM softp
),
507 "Intern a new symbol in @var{obarray}, a symbol table, with name\n"
509 "If @var{obarray} is @code{#f}, use the default system symbol table. If\n"
510 "@var{obarray} is @code{#t}, the symbol should not be interned in any\n"
511 "symbol table; merely return the pair (@var{symbol}\n"
512 ". @var{#<undefined>}).\n\n"
513 "The @var{soft?} argument determines whether new symbol table entries\n"
514 "should be created when the specified symbol is not already present in\n"
515 "@var{obarray}. If @var{soft?} is specified and is a true value, then\n"
516 "new entries should not be added for symbols not already present in the\n"
517 "table; instead, simply return @code{#f}.")
518 #define FUNC_NAME s_scm_string_to_obarray_symbol
524 SCM_VALIDATE_ROSTRING (2,s
);
525 SCM_ASSERT((o
== SCM_BOOL_F
)
528 o
, SCM_ARG1
, FUNC_NAME
);
530 softness
= ((softp
!= SCM_UNDEFINED
) && (softp
!= SCM_BOOL_F
));
531 /* iron out some screwy calling conventions */
534 else if (o
== SCM_BOOL_T
)
537 vcell
= scm_intern_obarray_soft (SCM_ROCHARS(s
),
538 (scm_sizet
)SCM_ROLENGTH(s
),
541 if (vcell
== SCM_BOOL_F
)
543 answer
= SCM_CAR (vcell
);
548 SCM_DEFINE (scm_intern_symbol
, "intern-symbol", 2, 0, 0,
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.")
553 #define FUNC_NAME s_scm_intern_symbol
556 SCM_VALIDATE_SYMBOL (2,s
);
559 SCM_VALIDATE_VECTOR (1,o
);
560 hval
= scm_strhash (SCM_UCHARS (s
), SCM_LENGTH (s
), SCM_LENGTH(o
));
561 /* If the symbol is already interned, simply return. */
566 for (lsym
= SCM_VELTS (o
)[hval
];
568 lsym
= SCM_CDR (lsym
))
570 sym
= SCM_CAR (lsym
);
571 if (SCM_CAR (sym
) == s
)
574 return SCM_UNSPECIFIED
;
577 SCM_VELTS (o
)[hval
] =
578 scm_acons (s
, SCM_UNDEFINED
, SCM_VELTS (o
)[hval
]);
581 return SCM_UNSPECIFIED
;
585 SCM_DEFINE (scm_unintern_symbol
, "unintern-symbol", 2, 0, 0,
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"
590 #define FUNC_NAME s_scm_unintern_symbol
593 SCM_VALIDATE_SYMBOL (2,s
);
596 SCM_VALIDATE_VECTOR (1,o
);
597 hval
= scm_strhash (SCM_UCHARS (s
), SCM_LENGTH (s
), SCM_LENGTH(o
));
603 for (lsym
= SCM_VELTS (o
)[hval
], lsym_follow
= SCM_BOOL_F
;
605 lsym_follow
= lsym
, lsym
= SCM_CDR (lsym
))
607 sym
= SCM_CAR (lsym
);
608 if (SCM_CAR (sym
) == s
)
610 /* Found the symbol to unintern. */
611 if (lsym_follow
== SCM_BOOL_F
)
612 SCM_VELTS(o
)[hval
] = lsym
;
614 SCM_SETCDR (lsym_follow
, SCM_CDR(lsym
));
625 SCM_DEFINE (scm_symbol_binding
, "symbol-binding", 2, 0, 0,
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.")
631 #define FUNC_NAME s_scm_symbol_binding
634 SCM_VALIDATE_SYMBOL (2,s
);
637 SCM_VALIDATE_VECTOR (1,o
);
638 vcell
= scm_sym2ovcell (s
, o
);
639 return SCM_CDR(vcell
);
644 SCM_DEFINE (scm_symbol_interned_p
, "symbol-interned?", 2, 0, 0,
646 "Return @var{#t} if @var{obarray} contains a symbol with name\n"
647 "@var{string}, and @var{#f} otherwise.")
648 #define FUNC_NAME s_scm_symbol_interned_p
651 SCM_VALIDATE_SYMBOL (2,s
);
654 SCM_VALIDATE_VECTOR (1,o
);
655 vcell
= scm_sym2ovcell_soft (s
, o
);
656 if (SCM_IMP(vcell
) && (o
== scm_symhash
))
657 vcell
= scm_sym2ovcell_soft (s
, scm_weak_symhash
);
658 return (SCM_NIMP(vcell
)
665 SCM_DEFINE (scm_symbol_bound_p
, "symbol-bound?", 2, 0, 0,
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.")
672 #define FUNC_NAME s_scm_symbol_bound_p
675 SCM_VALIDATE_SYMBOL (2,s
);
678 SCM_VALIDATE_VECTOR (1,o
);
679 vcell
= scm_sym2ovcell_soft (s
, o
);
680 return (( SCM_NIMP(vcell
)
681 && (SCM_CDR(vcell
) != SCM_UNDEFINED
))
688 SCM_DEFINE (scm_symbol_set_x
, "symbol-set!", 3, 0, 0,
689 (SCM o
, SCM s
, SCM v
),
690 "Find the symbol in @var{obarray} whose name is @var{string}, and rebind\n"
691 "it to @var{value}. An error is signalled if @var{string} is not present\n"
693 #define FUNC_NAME s_scm_symbol_set_x
696 SCM_VALIDATE_SYMBOL (2,s
);
699 SCM_VALIDATE_VECTOR (1,o
);
700 vcell
= scm_sym2ovcell (s
, o
);
701 SCM_SETCDR (vcell
, v
);
702 return SCM_UNSPECIFIED
;
710 string
= scm_makfromstr (SCM_CHARS (s
), SCM_LENGTH (s
), SCM_SYMBOL_SLOTS
);
711 SCM_SETCHARS (s
, SCM_CHARS (string
));
712 SCM_SETLENGTH (s
, SCM_LENGTH (s
), scm_tc7_msymbol
);
713 SCM_SETCDR (string
, SCM_EOL
);
714 SCM_SETCAR (string
, SCM_EOL
);
715 SCM_SYMBOL_PROPS (s
) = SCM_EOL
;
716 /* If it's a tc7_ssymbol, it comes from scm_symhash */
717 SCM_SYMBOL_HASH (s
) = scm_strhash (SCM_UCHARS (s
),
718 (scm_sizet
) SCM_LENGTH (s
),
719 SCM_LENGTH (scm_symhash
));
723 SCM_DEFINE (scm_symbol_fref
, "symbol-fref", 1, 0, 0,
725 "Return the contents of @var{symbol}'s @dfn{function slot}.")
726 #define FUNC_NAME s_scm_symbol_fref
728 SCM_VALIDATE_SYMBOL (1,s
);
730 if (SCM_TYP7(s
) == scm_tc7_ssymbol
)
733 return SCM_SYMBOL_FUNC (s
);
738 SCM_DEFINE (scm_symbol_pref
, "symbol-pref", 1, 0, 0,
740 "Return the @dfn{property list} currently associated with @var{symbol}.")
741 #define FUNC_NAME s_scm_symbol_pref
743 SCM_VALIDATE_SYMBOL (1,s
);
745 if (SCM_TYP7(s
) == scm_tc7_ssymbol
)
748 return SCM_SYMBOL_PROPS (s
);
753 SCM_DEFINE (scm_symbol_fset_x
, "symbol-fset!", 2, 0, 0,
755 "Change the binding of @var{symbol}'s function slot.")
756 #define FUNC_NAME s_scm_symbol_fset_x
758 SCM_VALIDATE_SYMBOL (1,s
);
760 if (SCM_TYP7(s
) == scm_tc7_ssymbol
)
763 SCM_SYMBOL_FUNC (s
) = val
;
764 return SCM_UNSPECIFIED
;
769 SCM_DEFINE (scm_symbol_pset_x
, "symbol-pset!", 2, 0, 0,
771 "Change the binding of @var{symbol}'s property slot.")
772 #define FUNC_NAME s_scm_symbol_pset_x
774 SCM_VALIDATE_SYMBOL (1,s
);
776 if (SCM_TYP7(s
) == scm_tc7_ssymbol
)
778 SCM_SYMBOL_PROPS (s
) = val
;
780 return SCM_UNSPECIFIED
;
785 SCM_DEFINE (scm_symbol_hash
, "symbol-hash", 1, 0, 0,
787 "Return the hash value derived from @var{symbol}'s name, i.e. the integer\n"
788 "index into @var{symbol}'s obarray at which it is stored.")
789 #define FUNC_NAME s_scm_symbol_hash
791 SCM_VALIDATE_SYMBOL (1,s
);
792 if (SCM_TYP7(s
) == scm_tc7_ssymbol
)
794 return SCM_MAKINUM ((unsigned long)s
^ SCM_SYMBOL_HASH (s
));
800 copy_and_prune_obarray (SCM from
, SCM to
)
803 int length
= SCM_LENGTH (from
);
804 for (i
= 0; i
< length
; ++i
)
806 SCM head
= SCM_VELTS (from
)[i
]; /* GC protection */
810 while (SCM_NIMP (ls
))
812 if (!SCM_UNBNDP (SCM_CDAR (ls
)))
814 *lloc
= scm_cons (SCM_CAR (ls
), SCM_EOL
);
815 lloc
= SCM_CDRLOC (*lloc
);
819 SCM_VELTS (to
)[i
] = res
;
824 SCM_DEFINE (scm_builtin_bindings
, "builtin-bindings", 0, 0, 0,
826 "Create and return a copy of the global symbol table, removing all\n"
828 #define FUNC_NAME s_scm_builtin_bindings
830 int length
= SCM_LENGTH (scm_symhash
);
831 SCM obarray
= scm_make_vector (SCM_MAKINUM (length
), SCM_EOL
);
832 copy_and_prune_obarray (scm_symhash
, obarray
);
838 SCM_DEFINE (scm_builtin_weak_bindings
, "builtin-weak-bindings", 0, 0, 0,
841 #define FUNC_NAME s_scm_builtin_weak_bindings
843 int length
= SCM_LENGTH (scm_weak_symhash
);
844 SCM obarray
= scm_make_doubly_weak_hash_table (SCM_MAKINUM (length
));
845 copy_and_prune_obarray (scm_weak_symhash
, obarray
);
850 static int gensym_counter
;
851 static SCM gensym_prefix
;
853 /* :FIXME:OPTIMIZE */
854 SCM_DEFINE (scm_gensym
, "gensym", 0, 2, 0,
855 (SCM name
, SCM obarray
),
856 "Create a new, unique symbol in @var{obarray}, using the global symbol\n"
857 "table by default. If @var{name} is specified, it should be used as a\n"
858 "prefix for the new symbol's name. The default prefix is @code{%%gensym}.")
859 #define FUNC_NAME s_scm_gensym
862 if (SCM_UNBNDP (name
))
863 name
= gensym_prefix
;
865 SCM_VALIDATE_ROSTRING (1,name
);
868 if (SCM_UNBNDP (obarray
))
870 obarray
= SCM_BOOL_F
;
874 SCM_ASSERT ((SCM_VECTORP (obarray
) || SCM_WVECTP (obarray
)),
878 while (scm_string_to_obarray_symbol (obarray
, new, SCM_BOOL_T
)
881 new = scm_string_append
883 scm_number_to_string (SCM_MAKINUM (gensym_counter
++),
886 return scm_string_to_obarray_symbol (obarray
, new, SCM_BOOL_F
);
894 gensym_prefix
= scm_permanent_object (scm_makfrom0str ("%%gensym"));