1 /* Copyright (C) 1995,1996,1997,1998, 2000 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 */
48 #include "libguile/_scm.h"
49 #include "libguile/chars.h"
50 #include "libguile/eval.h"
51 #include "libguile/hash.h"
52 #include "libguile/smob.h"
53 #include "libguile/variable.h"
54 #include "libguile/alist.h"
55 #include "libguile/fluids.h"
56 #include "libguile/strings.h"
57 #include "libguile/vectors.h"
58 #include "libguile/hashtab.h"
59 #include "libguile/weaks.h"
60 #include "libguile/modules.h"
62 #include "libguile/validate.h"
63 #include "libguile/symbols.h"
76 duplicate_string (const char * src
, unsigned long length
)
78 char * dst
= scm_must_malloc (length
+ 1, "duplicate_string");
79 memcpy (dst
, src
, length
);
91 scm_mem2symbol (const char *name
, scm_sizet len
)
93 scm_sizet raw_hash
= scm_string_hash ((const unsigned char *) name
, len
);
94 scm_sizet hash
= raw_hash
% SCM_VECTOR_LENGTH (symbols
);
97 /* Try to find the symbol in the symbols table */
101 for (l
= SCM_VELTS (symbols
) [hash
]; !SCM_NULLP (l
); l
= SCM_CDR (l
))
103 SCM sym
= SCM_CAAR (l
);
104 if (SCM_SYMBOL_HASH (sym
) == raw_hash
&& SCM_SYMBOL_LENGTH (sym
) == len
)
106 char *chrs
= SCM_SYMBOL_CHARS (sym
);
112 if (name
[i
] != chrs
[i
])
124 /* The symbol was not found - create it. */
130 SCM_NEWCELL2 (symbol
);
131 SCM_SET_SYMBOL_CHARS (symbol
, duplicate_string (name
, len
));
132 SCM_SET_SYMBOL_HASH (symbol
, raw_hash
);
133 SCM_SET_PROP_SLOTS (symbol
, scm_cons (SCM_BOOL_F
, SCM_EOL
));
134 SCM_SET_SYMBOL_LENGTH (symbol
, (long) len
);
136 cell
= scm_cons (symbol
, SCM_UNDEFINED
);
137 slot
= SCM_VELTS (symbols
) [hash
];
138 SCM_VELTS (symbols
) [hash
] = scm_cons (cell
, slot
);
146 scm_str2symbol (const char *str
)
148 return scm_mem2symbol (str
, strlen (str
));
153 * looks up the symbol in the symhash table.
157 scm_sym2vcell (SCM sym
, SCM thunk
, SCM definep
)
159 if (SCM_NIMP (thunk
))
163 if (SCM_EVAL_CLOSURE_P (thunk
))
164 /* Bypass evaluator in the standard case. */
165 var
= scm_eval_closure_lookup (thunk
, sym
, definep
);
167 var
= scm_apply (thunk
, sym
, scm_cons (definep
, scm_listofnull
));
169 if (SCM_FALSEP (var
))
171 else if (SCM_VARIABLEP (var
))
172 return SCM_VARVCELL (var
);
174 return scm_wta (sym
, "strangely interned symbol? ", "");
182 hash
= SCM_SYMBOL_HASH (sym
) % SCM_VECTOR_LENGTH (scm_symhash
);
183 for (lsym
= SCM_VELTS (scm_symhash
)[hash
]; SCM_NIMP (lsym
); lsym
= SCM_CDR (lsym
))
185 SCM z
= SCM_CAR (lsym
);
186 if (SCM_EQ_P (SCM_CAR (z
), sym
))
193 if (!SCM_FALSEP (definep
))
195 SCM cell
= scm_cons (sym
, SCM_UNDEFINED
);
196 SCM slot
= SCM_VELTS (scm_symhash
) [hash
];
198 SCM_VELTS (scm_symhash
) [hash
] = scm_cons (cell
, slot
);
212 * looks up the symbol in an arbitrary obarray.
216 scm_sym2ovcell_soft (SCM sym
, SCM obarray
)
219 scm_sizet hash
= SCM_SYMBOL_HASH (sym
) % SCM_VECTOR_LENGTH (obarray
);
221 for (lsym
= SCM_VELTS (obarray
)[hash
];
223 lsym
= SCM_CDR (lsym
))
226 if (SCM_EQ_P (SCM_CAR (z
), sym
))
238 scm_sym2ovcell (SCM sym
, SCM obarray
)
241 answer
= scm_sym2ovcell_soft (sym
, obarray
);
242 if (!SCM_FALSEP (answer
))
244 scm_wta (sym
, "uninterned symbol? ", "");
245 return SCM_UNSPECIFIED
; /* not reached */
248 /* Intern a symbol whose name is the LEN characters at NAME in OBARRAY.
250 OBARRAY should be a vector of lists, indexed by the name's hash
251 value, modulo OBARRAY's length. Each list has the form
252 ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the
253 value associated with that symbol (in the current module? in the
256 To "intern" a symbol means: if OBARRAY already contains a symbol by
257 that name, return its (SYMBOL . VALUE) pair; otherwise, create a
258 new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the
259 appropriate list of the OBARRAY, and return the pair.
261 If softness is non-zero, don't create a symbol if it isn't already
262 in OBARRAY; instead, just return #f.
264 If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and
265 return (SYMBOL . SCM_UNDEFINED). */
269 scm_intern_obarray_soft (const char *name
,scm_sizet len
,SCM obarray
,unsigned int softness
)
271 SCM symbol
= scm_mem2symbol (name
, len
);
272 scm_sizet raw_hash
= SCM_SYMBOL_HASH (symbol
);
276 if (SCM_FALSEP (obarray
))
281 return scm_cons (symbol
, SCM_UNDEFINED
);
284 hash
= raw_hash
% SCM_VECTOR_LENGTH (obarray
);
286 for (lsym
= SCM_VELTS (obarray
)[hash
]; SCM_NIMP (lsym
); lsym
= SCM_CDR (lsym
))
288 SCM a
= SCM_CAR (lsym
);
290 if (SCM_EQ_P (z
, symbol
))
300 SCM cell
= scm_cons (symbol
, SCM_UNDEFINED
);
301 SCM slot
= SCM_VELTS (obarray
) [hash
];
303 SCM_VELTS (obarray
) [hash
] = scm_cons (cell
, slot
);
311 scm_intern_obarray (const char *name
,scm_sizet len
,SCM obarray
)
313 return scm_intern_obarray_soft (name
, len
, obarray
, 0);
318 scm_intern (const char *name
,scm_sizet len
)
320 return scm_intern_obarray (name
, len
, scm_symhash
);
325 scm_intern0 (const char * name
)
327 return scm_intern (name
, strlen (name
));
331 /* Intern the symbol named NAME in scm_symhash, NAME is null-terminated. */
333 scm_sysintern0_no_module_lookup (const char *name
)
335 scm_sizet len
= strlen (name
);
338 easy_answer
= scm_intern_obarray_soft (name
, len
, scm_symhash
, 1);
339 if (SCM_NIMP (easy_answer
))
346 SCM symbol
= scm_mem2symbol (name
, len
);
347 scm_sizet raw_hash
= SCM_SYMBOL_HASH (symbol
);
348 scm_sizet hash
= raw_hash
% SCM_VECTOR_LENGTH (scm_symhash
);
349 SCM cell
= scm_cons (symbol
, SCM_UNDEFINED
);
350 SCM slot
= SCM_VELTS (scm_symhash
) [hash
];
352 SCM_VELTS (scm_symhash
) [hash
] = scm_cons (cell
, slot
);
358 /* Intern the symbol named NAME in scm_symhash, and give it the value
359 VAL. NAME is null-terminated. Use the current top_level lookup
360 closure to give NAME its value.
363 scm_sysintern (const char *name
, SCM val
)
365 SCM vcell
= scm_sysintern0 (name
);
366 SCM_SETCDR (vcell
, val
);
371 scm_sysintern0 (const char *name
)
374 if (scm_module_system_booted_p
375 && SCM_NIMP (lookup_proc
= SCM_TOP_LEVEL_LOOKUP_CLOSURE
))
377 SCM sym
= scm_str2symbol (name
);
378 SCM vcell
= scm_sym2vcell (sym
, lookup_proc
, SCM_BOOL_T
);
379 if (SCM_FALSEP (vcell
))
380 scm_misc_error ("sysintern0", "can't define variable", sym
);
384 return scm_sysintern0_no_module_lookup (name
);
387 /* Lookup the value of the symbol named by the nul-terminated string
388 NAME in the current module. */
390 scm_symbol_value0 (const char *name
)
392 /* This looks silly - we look up the symbol twice. But it is in
393 fact necessary given the current module system because the module
394 lookup closures are written in scheme which needs real symbols. */
395 SCM symbol
= scm_str2symbol (name
);
396 SCM vcell
= scm_sym2vcell (symbol
, SCM_TOP_LEVEL_LOOKUP_CLOSURE
, SCM_BOOL_F
);
397 if (SCM_FALSEP (vcell
))
398 return SCM_UNDEFINED
;
399 return SCM_CDR (vcell
);
403 SCM_DEFINE (scm_symbol_p
, "symbol?", 1, 0, 0,
405 "Returns @code{#t} if @var{obj} is a symbol, otherwise returns\n"
407 #define FUNC_NAME s_scm_symbol_p
409 return SCM_BOOL (SCM_SYMBOLP (obj
));
413 SCM_DEFINE (scm_symbol_to_string
, "symbol->string", 1, 0, 0,
415 "Returns the name of @var{symbol} as a string. If the symbol\n"
416 "was part of an object returned as the value of a literal\n"
417 "expression (section @pxref{Literal expressions,,,r4rs, The\n"
418 "Revised^4 Report on Scheme}) or by a call to the @code{read}\n"
419 "procedure, and its name contains alphabetic characters, then\n"
420 "the string returned will contain characters in the\n"
421 "implementation's preferred standard case---some implementations\n"
422 "will prefer upper case, others lower case. If the symbol was\n"
423 "returned by @code{string->symbol}, the case of characters in\n"
424 "the string returned will be the same as the case in the string\n"
425 "that was passed to @code{string->symbol}. It is an error to\n"
426 "apply mutation procedures like @code{string-set!} to strings\n"
427 "returned by this procedure. (r5rs)\n\n"
428 "The following examples assume that the implementation's\n"
429 "standard case is lower case:\n\n"
431 "(symbol->string 'flying-fish) @result{} \"flying-fish\"\n"
432 "(symbol->string 'Martin) @result{} \"martin\"\n"
434 " (string->symbol \"Malvina\")) @result{} \"Malvina\"\n"
436 #define FUNC_NAME s_scm_symbol_to_string
438 SCM_VALIDATE_SYMBOL (1, s
);
439 return scm_makfromstr (SCM_SYMBOL_CHARS (s
), SCM_SYMBOL_LENGTH (s
), 0);
444 SCM_DEFINE (scm_string_to_symbol
, "string->symbol", 1, 0, 0,
446 "Returns the symbol whose name is @var{string}. This procedure\n"
447 "can create symbols with names containing special characters or\n"
448 "letters in the non-standard case, but it is usually a bad idea\n"
449 "to create such because in some implementations of Scheme they\n"
450 "cannot be read as themselves. See @code{symbol->string}.\n\n"
451 "The following examples assume that the implementation's\n"
452 "standard case is lower case:\n\n"
454 "(eq? 'mISSISSIppi 'mississippi) @result{} #t\n"
455 "(string->symbol \"mISSISSIppi\") @result{} @r{the symbol with name \"mISSISSIppi\"}\n"
456 "(eq? 'bitBlt (string->symbol \"bitBlt\")) @result{} #f\n"
458 " (string->symbol (symbol->string 'JollyWog))) @result{} #t\n"
459 "(string=? \"K. Harper, M.D.\"\n"
461 " (string->symbol \"K. Harper, M.D.\"))) @result{}#t\n"
463 #define FUNC_NAME s_scm_string_to_symbol
465 SCM_VALIDATE_STRING (1, s
);
466 return scm_mem2symbol (SCM_STRING_CHARS (s
), SCM_STRING_LENGTH (s
));
471 SCM_DEFINE (scm_string_to_obarray_symbol
, "string->obarray-symbol", 2, 1, 0,
472 (SCM o
, SCM s
, SCM softp
),
473 "Intern a new symbol in @var{obarray}, a symbol table, with name\n"
475 "If @var{obarray} is @code{#f}, use the default system symbol table. If\n"
476 "@var{obarray} is @code{#t}, the symbol should not be interned in any\n"
477 "symbol table; merely return the pair (@var{symbol}\n"
478 ". @var{#<undefined>}).\n\n"
479 "The @var{soft?} argument determines whether new symbol table entries\n"
480 "should be created when the specified symbol is not already present in\n"
481 "@var{obarray}. If @var{soft?} is specified and is a true value, then\n"
482 "new entries should not be added for symbols not already present in the\n"
483 "table; instead, simply return @code{#f}.")
484 #define FUNC_NAME s_scm_string_to_obarray_symbol
490 SCM_VALIDATE_STRING (2, s
);
491 SCM_ASSERT (SCM_BOOLP (o
) || SCM_VECTORP (o
), o
, SCM_ARG1
, FUNC_NAME
);
493 softness
= (!SCM_UNBNDP (softp
) && !SCM_FALSEP(softp
));
494 /* iron out some screwy calling conventions */
497 else if (SCM_EQ_P (o
, SCM_BOOL_T
))
500 vcell
= scm_intern_obarray_soft (SCM_STRING_CHARS(s
),
501 SCM_STRING_LENGTH (s
),
504 if (SCM_FALSEP (vcell
))
506 answer
= SCM_CAR (vcell
);
511 SCM_DEFINE (scm_intern_symbol
, "intern-symbol", 2, 0, 0,
513 "Add a new symbol to @var{obarray} with name @var{string}, bound to an\n"
514 "unspecified initial value. The symbol table is not modified if a symbol\n"
515 "with this name is already present.")
516 #define FUNC_NAME s_scm_intern_symbol
519 SCM_VALIDATE_SYMBOL (2,s
);
522 SCM_VALIDATE_VECTOR (1,o
);
523 hval
= SCM_SYMBOL_HASH (s
) % SCM_VECTOR_LENGTH (o
);
524 /* If the symbol is already interned, simply return. */
529 for (lsym
= SCM_VELTS (o
)[hval
];
531 lsym
= SCM_CDR (lsym
))
533 sym
= SCM_CAR (lsym
);
534 if (SCM_EQ_P (SCM_CAR (sym
), s
))
537 return SCM_UNSPECIFIED
;
540 SCM_VELTS (o
)[hval
] =
541 scm_acons (s
, SCM_UNDEFINED
, SCM_VELTS (o
)[hval
]);
544 return SCM_UNSPECIFIED
;
548 SCM_DEFINE (scm_unintern_symbol
, "unintern-symbol", 2, 0, 0,
550 "Remove the symbol with name @var{string} from @var{obarray}. This\n"
551 "function returns @code{#t} if the symbol was present and @code{#f}\n"
553 #define FUNC_NAME s_scm_unintern_symbol
556 SCM_VALIDATE_SYMBOL (2,s
);
559 SCM_VALIDATE_VECTOR (1,o
);
560 hval
= SCM_SYMBOL_HASH (s
) % SCM_VECTOR_LENGTH (o
);
566 for (lsym
= SCM_VELTS (o
)[hval
], lsym_follow
= SCM_BOOL_F
;
568 lsym_follow
= lsym
, lsym
= SCM_CDR (lsym
))
570 sym
= SCM_CAR (lsym
);
571 if (SCM_EQ_P (SCM_CAR (sym
), s
))
573 /* Found the symbol to unintern. */
574 if (SCM_FALSEP (lsym_follow
))
575 SCM_VELTS(o
)[hval
] = lsym
;
577 SCM_SETCDR (lsym_follow
, SCM_CDR(lsym
));
588 SCM_DEFINE (scm_symbol_binding
, "symbol-binding", 2, 0, 0,
590 "Look up in @var{obarray} the symbol whose name is @var{string}, and\n"
591 "return the value to which it is bound. If @var{obarray} is @code{#f},\n"
592 "use the global symbol table. If @var{string} is not interned in\n"
593 "@var{obarray}, an error is signalled.")
594 #define FUNC_NAME s_scm_symbol_binding
597 SCM_VALIDATE_SYMBOL (2,s
);
600 SCM_VALIDATE_VECTOR (1,o
);
601 vcell
= scm_sym2ovcell (s
, o
);
602 return SCM_CDR(vcell
);
607 SCM_DEFINE (scm_symbol_interned_p
, "symbol-interned?", 2, 0, 0,
609 "Return @var{#t} if @var{obarray} contains a symbol with name\n"
610 "@var{string}, and @var{#f} otherwise.")
611 #define FUNC_NAME s_scm_symbol_interned_p
614 SCM_VALIDATE_SYMBOL (2,s
);
617 SCM_VALIDATE_VECTOR (1,o
);
618 vcell
= scm_sym2ovcell_soft (s
, o
);
619 return (SCM_NIMP(vcell
)
626 SCM_DEFINE (scm_symbol_bound_p
, "symbol-bound?", 2, 0, 0,
628 "Return @var{#t} if @var{obarray} contains a symbol with name\n"
629 "@var{string} bound to a defined value. This differs from\n"
630 "@var{symbol-interned?} in that the mere mention of a symbol usually causes\n"
631 "it to be interned; @code{symbol-bound?} determines whether a symbol has\n"
632 "been given any meaningful value.")
633 #define FUNC_NAME s_scm_symbol_bound_p
636 SCM_VALIDATE_SYMBOL (2,s
);
639 SCM_VALIDATE_VECTOR (1,o
);
640 vcell
= scm_sym2ovcell_soft (s
, o
);
641 return SCM_BOOL (SCM_NIMP (vcell
) && !SCM_UNBNDP (SCM_CDR (vcell
)));
646 SCM_DEFINE (scm_symbol_set_x
, "symbol-set!", 3, 0, 0,
647 (SCM o
, SCM s
, SCM v
),
648 "Find the symbol in @var{obarray} whose name is @var{string}, and rebind\n"
649 "it to @var{value}. An error is signalled if @var{string} is not present\n"
651 #define FUNC_NAME s_scm_symbol_set_x
654 SCM_VALIDATE_SYMBOL (2,s
);
657 SCM_VALIDATE_VECTOR (1,o
);
658 vcell
= scm_sym2ovcell (s
, o
);
659 SCM_SETCDR (vcell
, v
);
660 return SCM_UNSPECIFIED
;
665 SCM_DEFINE (scm_symbol_fref
, "symbol-fref", 1, 0, 0,
667 "Return the contents of @var{symbol}'s @dfn{function slot}.")
668 #define FUNC_NAME s_scm_symbol_fref
670 SCM_VALIDATE_SYMBOL (1,s
);
671 return SCM_SYMBOL_FUNC (s
);
676 SCM_DEFINE (scm_symbol_pref
, "symbol-pref", 1, 0, 0,
678 "Return the @dfn{property list} currently associated with @var{symbol}.")
679 #define FUNC_NAME s_scm_symbol_pref
681 SCM_VALIDATE_SYMBOL (1,s
);
682 return SCM_SYMBOL_PROPS (s
);
687 SCM_DEFINE (scm_symbol_fset_x
, "symbol-fset!", 2, 0, 0,
689 "Change the binding of @var{symbol}'s function slot.")
690 #define FUNC_NAME s_scm_symbol_fset_x
692 SCM_VALIDATE_SYMBOL (1,s
);
693 SCM_SET_SYMBOL_FUNC (s
, val
);
694 return SCM_UNSPECIFIED
;
699 SCM_DEFINE (scm_symbol_pset_x
, "symbol-pset!", 2, 0, 0,
701 "Change the binding of @var{symbol}'s property slot.")
702 #define FUNC_NAME s_scm_symbol_pset_x
704 SCM_VALIDATE_SYMBOL (1,s
);
706 SCM_SET_SYMBOL_PROPS (s
, val
);
708 return SCM_UNSPECIFIED
;
713 SCM_DEFINE (scm_symbol_hash
, "symbol-hash", 1, 0, 0,
715 "Return a hash value for @var{symbol}.")
716 #define FUNC_NAME s_scm_symbol_hash
718 SCM_VALIDATE_SYMBOL (1, symbol
);
719 return SCM_MAKINUM (SCM_SYMBOL_HASH (symbol
));
725 copy_and_prune_obarray (SCM from
, SCM to
)
728 int length
= SCM_VECTOR_LENGTH (from
);
729 for (i
= 0; i
< length
; ++i
)
731 SCM head
= SCM_VELTS (from
)[i
]; /* GC protection */
735 while (SCM_NIMP (ls
))
737 if (!SCM_UNBNDP (SCM_CDAR (ls
)))
739 *lloc
= scm_cons (SCM_CAR (ls
), SCM_EOL
);
740 lloc
= SCM_CDRLOC (*lloc
);
744 SCM_VELTS (to
)[i
] = res
;
749 SCM_DEFINE (scm_builtin_bindings
, "builtin-bindings", 0, 0, 0,
751 "Create and return a copy of the global symbol table, removing all\n"
753 #define FUNC_NAME s_scm_builtin_bindings
755 int length
= SCM_VECTOR_LENGTH (scm_symhash
);
756 SCM obarray
= scm_c_make_hash_table (length
);
757 copy_and_prune_obarray (scm_symhash
, obarray
);
763 #define MAX_PREFIX_LENGTH 30
765 static int gensym_counter
;
767 SCM_DEFINE (scm_gensym
, "gensym", 0, 1, 0,
769 "Create a new symbol with a name constructed from a prefix and\n"
770 "a counter value. The string @var{prefix} can be specified as\n"
771 "an optional argument. Default prefix is @code{g}. The counter\n"
772 "is increased by 1 at each call. There is no provision for\n"
773 "resetting the counter.")
774 #define FUNC_NAME s_scm_gensym
776 char buf
[MAX_PREFIX_LENGTH
+ SCM_INTBUFLEN
];
779 if (SCM_UNBNDP (prefix
))
786 SCM_VALIDATE_STRING (1, prefix
);
787 len
= SCM_STRING_LENGTH (prefix
);
788 if (len
> MAX_PREFIX_LENGTH
)
789 name
= SCM_MUST_MALLOC (MAX_PREFIX_LENGTH
+ SCM_INTBUFLEN
);
790 strncpy (name
, SCM_STRING_CHARS (prefix
), len
);
793 int n_digits
= scm_iint2str (gensym_counter
++, 10, &name
[len
]);
794 SCM res
= scm_mem2symbol (name
, len
+ n_digits
);
796 scm_must_free (name
);
802 static int gentemp_counter
;
804 SCM_DEFINE (scm_gentemp
, "gentemp", 0, 2, 0,
805 (SCM prefix
, SCM obarray
),
806 "Create a new symbol with a name unique in an obarray.\n"
807 "The name is constructed from an optional string @var{prefix}\n"
808 "and a counter value. The default prefix is @code{t}. The\n"
809 "@var{obarray} is specified as a second optional argument.\n"
810 "Default is the system obarray where all normal symbols are\n"
811 "interned. The counter is increased by 1 at each\n"
812 "call. There is no provision for resetting the counter.")
813 #define FUNC_NAME s_scm_gentemp
815 char buf
[MAX_PREFIX_LENGTH
+ SCM_INTBUFLEN
];
818 if (SCM_UNBNDP (prefix
))
825 SCM_VALIDATE_STRING (1, prefix
);
826 len
= SCM_STRING_LENGTH (prefix
);
827 if (len
> MAX_PREFIX_LENGTH
)
828 name
= SCM_MUST_MALLOC (MAX_PREFIX_LENGTH
+ SCM_INTBUFLEN
);
829 strncpy (name
, SCM_STRING_CHARS (prefix
), len
);
832 if (SCM_UNBNDP (obarray
))
833 obarray
= scm_symhash
;
835 SCM_ASSERT ((SCM_VECTORP (obarray
) || SCM_WVECTP (obarray
)),
840 n_digits
= scm_iint2str (gentemp_counter
++, 10, &name
[len
]);
841 while (!SCM_FALSEP (scm_intern_obarray_soft (name
,
846 SCM vcell
= scm_intern_obarray_soft (name
,
851 scm_must_free (name
);
852 return SCM_CAR (vcell
);
859 scm_symbols_prehistory ()
861 symbols
= scm_make_weak_key_hash_table (SCM_MAKINUM (277));
862 scm_permanent_object (symbols
);
871 #ifndef SCM_MAGIC_SNARFER
872 #include "libguile/symbols.x"