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/weaks.h"
59 #include "libguile/modules.h"
61 #include "libguile/validate.h"
62 #include "libguile/symbols.h"
71 duplicate_string (const char * src
, unsigned long length
)
73 char * dst
= scm_must_malloc (length
+ 1, "duplicate_string");
74 memcpy (dst
, src
, length
);
86 scm_mem2symbol (const char *name
, scm_sizet len
)
88 scm_sizet raw_hash
= scm_string_hash ((const unsigned char *) name
, len
);
89 scm_sizet hash
= raw_hash
% SCM_VECTOR_LENGTH (scm_symbols
);
92 /* Try to find the symbol in the scm_symbols table */
96 for (l
= SCM_VELTS (scm_symbols
) [hash
]; !SCM_NULLP (l
); l
= SCM_CDR (l
))
98 SCM sym
= SCM_CAAR (l
);
99 if (SCM_SYMBOL_HASH (sym
) == raw_hash
&& SCM_SYMBOL_LENGTH (sym
) == len
)
101 char *chrs
= SCM_SYMBOL_CHARS (sym
);
107 if (name
[i
] != chrs
[i
])
118 /* The symbol was not found - create it. */
124 SCM_NEWCELL2 (symbol
);
125 SCM_SET_SYMBOL_CHARS (symbol
, duplicate_string (name
, len
));
126 SCM_SET_SYMBOL_HASH (symbol
, raw_hash
);
127 SCM_SET_PROP_SLOTS (symbol
, scm_cons (SCM_BOOL_F
, SCM_EOL
));
128 SCM_SET_SYMBOL_LENGTH (symbol
, (long) len
);
130 cell
= scm_cons (symbol
, SCM_UNDEFINED
);
131 slot
= SCM_VELTS (scm_symbols
) [hash
];
132 SCM_VELTS (scm_symbols
) [hash
] = scm_cons (cell
, slot
);
140 scm_str2symbol (const char *str
)
142 return scm_mem2symbol (str
, strlen (str
));
147 * looks up the symbol in the symhash table.
151 scm_sym2vcell (SCM sym
, SCM thunk
, SCM definep
)
153 if (SCM_NIMP (thunk
))
157 if (SCM_EVAL_CLOSURE_P (thunk
))
158 /* Bypass evaluator in the standard case. */
159 var
= scm_eval_closure_lookup (thunk
, sym
, definep
);
161 var
= scm_apply (thunk
, sym
, scm_cons (definep
, scm_listofnull
));
163 if (SCM_FALSEP (var
))
165 else if (SCM_VARIABLEP (var
))
166 return SCM_VARVCELL (var
);
168 return scm_wta (sym
, "strangely interned symbol? ", "");
176 hash
= SCM_SYMBOL_HASH (sym
) % SCM_VECTOR_LENGTH (scm_symhash
);
177 for (lsym
= SCM_VELTS (scm_symhash
)[hash
]; SCM_NIMP (lsym
); lsym
= SCM_CDR (lsym
))
179 SCM z
= SCM_CAR (lsym
);
180 if (SCM_EQ_P (SCM_CAR (z
), sym
))
187 if (!SCM_FALSEP (definep
))
189 SCM cell
= scm_cons (sym
, SCM_UNDEFINED
);
190 SCM slot
= SCM_VELTS (scm_symhash
) [hash
];
192 SCM_VELTS (scm_symhash
) [hash
] = scm_cons (cell
, slot
);
206 * looks up the symbol in an arbitrary obarray.
210 scm_sym2ovcell_soft (SCM sym
, SCM obarray
)
213 scm_sizet hash
= SCM_SYMBOL_HASH (sym
) % SCM_VECTOR_LENGTH (obarray
);
215 for (lsym
= SCM_VELTS (obarray
)[hash
];
217 lsym
= SCM_CDR (lsym
))
220 if (SCM_EQ_P (SCM_CAR (z
), sym
))
232 scm_sym2ovcell (SCM sym
, SCM obarray
)
235 answer
= scm_sym2ovcell_soft (sym
, obarray
);
236 if (!SCM_FALSEP (answer
))
238 scm_wta (sym
, "uninterned symbol? ", "");
239 return SCM_UNSPECIFIED
; /* not reached */
242 /* Intern a symbol whose name is the LEN characters at NAME in OBARRAY.
244 OBARRAY should be a vector of lists, indexed by the name's hash
245 value, modulo OBARRAY's length. Each list has the form
246 ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the
247 value associated with that symbol (in the current module? in the
250 To "intern" a symbol means: if OBARRAY already contains a symbol by
251 that name, return its (SYMBOL . VALUE) pair; otherwise, create a
252 new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the
253 appropriate list of the OBARRAY, and return the pair.
255 If softness is non-zero, don't create a symbol if it isn't already
256 in OBARRAY; instead, just return #f.
258 If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and
259 return (SYMBOL . SCM_UNDEFINED). */
263 scm_intern_obarray_soft (const char *name
,scm_sizet len
,SCM obarray
,unsigned int softness
)
265 SCM symbol
= scm_mem2symbol (name
, len
);
266 scm_sizet raw_hash
= SCM_SYMBOL_HASH (symbol
);
270 if (SCM_FALSEP (obarray
))
275 return scm_cons (symbol
, SCM_UNDEFINED
);
278 hash
= raw_hash
% SCM_VECTOR_LENGTH (obarray
);
280 for (lsym
= SCM_VELTS (obarray
)[hash
]; SCM_NIMP (lsym
); lsym
= SCM_CDR (lsym
))
282 SCM a
= SCM_CAR (lsym
);
284 if (SCM_EQ_P (z
, symbol
))
294 SCM cell
= scm_cons (symbol
, SCM_UNDEFINED
);
295 SCM slot
= SCM_VELTS (obarray
) [hash
];
297 SCM_VELTS (obarray
) [hash
] = scm_cons (cell
, slot
);
305 scm_intern_obarray (const char *name
,scm_sizet len
,SCM obarray
)
307 return scm_intern_obarray_soft (name
, len
, obarray
, 0);
312 scm_intern (const char *name
,scm_sizet len
)
314 return scm_intern_obarray (name
, len
, scm_symhash
);
319 scm_intern0 (const char * name
)
321 return scm_intern (name
, strlen (name
));
325 /* Intern the symbol named NAME in scm_symhash, NAME is null-terminated. */
327 scm_sysintern0_no_module_lookup (const char *name
)
329 scm_sizet len
= strlen (name
);
332 easy_answer
= scm_intern_obarray_soft (name
, len
, scm_symhash
, 1);
333 if (SCM_NIMP (easy_answer
))
340 SCM symbol
= scm_mem2symbol (name
, len
);
341 scm_sizet raw_hash
= SCM_SYMBOL_HASH (symbol
);
342 scm_sizet hash
= raw_hash
% SCM_VECTOR_LENGTH (scm_symhash
);
343 SCM cell
= scm_cons (symbol
, SCM_UNDEFINED
);
344 SCM slot
= SCM_VELTS (scm_symhash
) [hash
];
346 SCM_VELTS (scm_symhash
) [hash
] = scm_cons (cell
, slot
);
352 /* Intern the symbol named NAME in scm_symhash, and give it the value
353 VAL. NAME is null-terminated. Use the current top_level lookup
354 closure to give NAME its value.
357 scm_sysintern (const char *name
, SCM val
)
359 SCM vcell
= scm_sysintern0 (name
);
360 SCM_SETCDR (vcell
, val
);
365 scm_sysintern0 (const char *name
)
368 if (scm_module_system_booted_p
369 && SCM_NIMP (lookup_proc
= SCM_TOP_LEVEL_LOOKUP_CLOSURE
))
371 SCM sym
= scm_str2symbol (name
);
372 SCM vcell
= scm_sym2vcell (sym
, lookup_proc
, SCM_BOOL_T
);
373 if (SCM_FALSEP (vcell
))
374 scm_misc_error ("sysintern0", "can't define variable", sym
);
378 return scm_sysintern0_no_module_lookup (name
);
381 /* Lookup the value of the symbol named by the nul-terminated string
382 NAME in the current module. */
384 scm_symbol_value0 (const char *name
)
386 /* This looks silly - we look up the symbol twice. But it is in
387 fact necessary given the current module system because the module
388 lookup closures are written in scheme which needs real symbols. */
389 SCM symbol
= scm_str2symbol (name
);
390 SCM vcell
= scm_sym2vcell (symbol
, SCM_TOP_LEVEL_LOOKUP_CLOSURE
, SCM_BOOL_F
);
391 if (SCM_FALSEP (vcell
))
392 return SCM_UNDEFINED
;
393 return SCM_CDR (vcell
);
396 SCM_DEFINE (scm_symbol_p
, "symbol?", 1, 0, 0,
398 "Returns @t{#t} if @var{obj} is a symbol, otherwise returns @t{#f}. (r5rs)")
399 #define FUNC_NAME s_scm_symbol_p
401 return SCM_BOOL (SCM_SYMBOLP (obj
));
405 SCM_DEFINE (scm_symbol_to_string
, "symbol->string", 1, 0, 0,
407 "Returns the name of @var{symbol} as a string. If the symbol was part of\n"
408 "an object returned as the value of a literal expression (section\n"
409 "@pxref{Literal expressions,,,r4rs, The Revised^4 Report on Scheme}) or\n"
410 "by a call to the @samp{read} procedure, and its name contains alphabetic\n"
411 "characters, then the string returned will contain characters in the\n"
412 "implementation's preferred standard case---some implementations will\n"
413 "prefer upper case, others lower case. If the symbol was returned by\n"
414 "@samp{string->symbol}, the case of characters in the string returned\n"
415 "will be the same as the case in the string that was passed to\n"
416 "@samp{string->symbol}. It is an error to apply mutation procedures like\n"
417 "@code{string-set!} to strings returned by this procedure. (r5rs)\n\n"
418 "The following examples assume that the implementation's standard case is\n"
421 "@t{(symbol->string 'flying-fish) \n"
422 " ==> \"flying-fish\"\n"
423 "(symbol->string 'Martin) ==> \"martin\"\n"
425 " (string->symbol \"Malvina\")) \n"
429 #define FUNC_NAME s_scm_symbol_to_string
431 SCM_VALIDATE_SYMBOL (1, s
);
432 return scm_makfromstr (SCM_SYMBOL_CHARS (s
), SCM_SYMBOL_LENGTH (s
), 0);
437 SCM_DEFINE (scm_string_to_symbol
, "string->symbol", 1, 0, 0,
439 "Returns the symbol whose name is @var{string}. This procedure can\n"
440 "create symbols with names containing special characters or letters in\n"
441 "the non-standard case, but it is usually a bad idea to create such\n"
442 "symbols because in some implementations of Scheme they cannot be read as\n"
443 "themselves. See @samp{symbol->string}.\n\n"
444 "The following examples assume that the implementation's standard case is\n"
447 "@t{(eq? 'mISSISSIppi 'mississippi) \n"
449 "(string->symbol \"mISSISSIppi\") \n"
451 " @r{}the symbol with name \"mISSISSIppi\"\n"
452 "(eq? 'bitBlt (string->symbol \"bitBlt\")) \n"
456 " (symbol->string 'JollyWog))) \n"
458 "(string=? \"K. Harper, M.D.\"\n"
460 " (string->symbol \"K. Harper, M.D.\"))) \n"
464 #define FUNC_NAME s_scm_string_to_symbol
466 SCM_VALIDATE_STRING (1, s
);
467 return scm_mem2symbol (SCM_STRING_CHARS (s
), SCM_STRING_LENGTH (s
));
472 SCM_DEFINE (scm_string_to_obarray_symbol
, "string->obarray-symbol", 2, 1, 0,
473 (SCM o
, SCM s
, SCM softp
),
474 "Intern a new symbol in @var{obarray}, a symbol table, with name\n"
476 "If @var{obarray} is @code{#f}, use the default system symbol table. If\n"
477 "@var{obarray} is @code{#t}, the symbol should not be interned in any\n"
478 "symbol table; merely return the pair (@var{symbol}\n"
479 ". @var{#<undefined>}).\n\n"
480 "The @var{soft?} argument determines whether new symbol table entries\n"
481 "should be created when the specified symbol is not already present in\n"
482 "@var{obarray}. If @var{soft?} is specified and is a true value, then\n"
483 "new entries should not be added for symbols not already present in the\n"
484 "table; instead, simply return @code{#f}.")
485 #define FUNC_NAME s_scm_string_to_obarray_symbol
491 SCM_VALIDATE_STRING (2, s
);
492 SCM_ASSERT (SCM_BOOLP (o
) || SCM_VECTORP (o
), o
, SCM_ARG1
, FUNC_NAME
);
494 softness
= (!SCM_UNBNDP (softp
) && !SCM_FALSEP(softp
));
495 /* iron out some screwy calling conventions */
498 else if (SCM_EQ_P (o
, SCM_BOOL_T
))
501 vcell
= scm_intern_obarray_soft (SCM_STRING_CHARS(s
),
502 SCM_STRING_LENGTH (s
),
505 if (SCM_FALSEP (vcell
))
507 answer
= SCM_CAR (vcell
);
512 SCM_DEFINE (scm_intern_symbol
, "intern-symbol", 2, 0, 0,
514 "Add a new symbol to @var{obarray} with name @var{string}, bound to an\n"
515 "unspecified initial value. The symbol table is not modified if a symbol\n"
516 "with this name is already present.")
517 #define FUNC_NAME s_scm_intern_symbol
520 SCM_VALIDATE_SYMBOL (2,s
);
523 SCM_VALIDATE_VECTOR (1,o
);
524 hval
= SCM_SYMBOL_HASH (s
) % SCM_VECTOR_LENGTH (o
);
525 /* If the symbol is already interned, simply return. */
530 for (lsym
= SCM_VELTS (o
)[hval
];
532 lsym
= SCM_CDR (lsym
))
534 sym
= SCM_CAR (lsym
);
535 if (SCM_EQ_P (SCM_CAR (sym
), s
))
538 return SCM_UNSPECIFIED
;
541 SCM_VELTS (o
)[hval
] =
542 scm_acons (s
, SCM_UNDEFINED
, SCM_VELTS (o
)[hval
]);
545 return SCM_UNSPECIFIED
;
549 SCM_DEFINE (scm_unintern_symbol
, "unintern-symbol", 2, 0, 0,
551 "Remove the symbol with name @var{string} from @var{obarray}. This\n"
552 "function returns @code{#t} if the symbol was present and @code{#f}\n"
554 #define FUNC_NAME s_scm_unintern_symbol
557 SCM_VALIDATE_SYMBOL (2,s
);
560 SCM_VALIDATE_VECTOR (1,o
);
561 hval
= SCM_SYMBOL_HASH (s
) % SCM_VECTOR_LENGTH (o
);
567 for (lsym
= SCM_VELTS (o
)[hval
], lsym_follow
= SCM_BOOL_F
;
569 lsym_follow
= lsym
, lsym
= SCM_CDR (lsym
))
571 sym
= SCM_CAR (lsym
);
572 if (SCM_EQ_P (SCM_CAR (sym
), s
))
574 /* Found the symbol to unintern. */
575 if (SCM_FALSEP (lsym_follow
))
576 SCM_VELTS(o
)[hval
] = lsym
;
578 SCM_SETCDR (lsym_follow
, SCM_CDR(lsym
));
589 SCM_DEFINE (scm_symbol_binding
, "symbol-binding", 2, 0, 0,
591 "Look up in @var{obarray} the symbol whose name is @var{string}, and\n"
592 "return the value to which it is bound. If @var{obarray} is @code{#f},\n"
593 "use the global symbol table. If @var{string} is not interned in\n"
594 "@var{obarray}, an error is signalled.")
595 #define FUNC_NAME s_scm_symbol_binding
598 SCM_VALIDATE_SYMBOL (2,s
);
601 SCM_VALIDATE_VECTOR (1,o
);
602 vcell
= scm_sym2ovcell (s
, o
);
603 return SCM_CDR(vcell
);
608 SCM_DEFINE (scm_symbol_interned_p
, "symbol-interned?", 2, 0, 0,
610 "Return @var{#t} if @var{obarray} contains a symbol with name\n"
611 "@var{string}, and @var{#f} otherwise.")
612 #define FUNC_NAME s_scm_symbol_interned_p
615 SCM_VALIDATE_SYMBOL (2,s
);
618 SCM_VALIDATE_VECTOR (1,o
);
619 vcell
= scm_sym2ovcell_soft (s
, o
);
620 return (SCM_NIMP(vcell
)
627 SCM_DEFINE (scm_symbol_bound_p
, "symbol-bound?", 2, 0, 0,
629 "Return @var{#t} if @var{obarray} contains a symbol with name\n"
630 "@var{string} bound to a defined value. This differs from\n"
631 "@var{symbol-bound?} in that the mere mention of a symbol usually causes\n"
632 "it to be interned; @code{symbol-bound?} determines whether a symbol has\n"
633 "been given any meaningful value.")
634 #define FUNC_NAME s_scm_symbol_bound_p
637 SCM_VALIDATE_SYMBOL (2,s
);
640 SCM_VALIDATE_VECTOR (1,o
);
641 vcell
= scm_sym2ovcell_soft (s
, o
);
642 return SCM_BOOL (SCM_NIMP (vcell
) && !SCM_UNBNDP (SCM_CDR (vcell
)));
647 SCM_DEFINE (scm_symbol_set_x
, "symbol-set!", 3, 0, 0,
648 (SCM o
, SCM s
, SCM v
),
649 "Find the symbol in @var{obarray} whose name is @var{string}, and rebind\n"
650 "it to @var{value}. An error is signalled if @var{string} is not present\n"
652 #define FUNC_NAME s_scm_symbol_set_x
655 SCM_VALIDATE_SYMBOL (2,s
);
658 SCM_VALIDATE_VECTOR (1,o
);
659 vcell
= scm_sym2ovcell (s
, o
);
660 SCM_SETCDR (vcell
, v
);
661 return SCM_UNSPECIFIED
;
666 SCM_DEFINE (scm_symbol_fref
, "symbol-fref", 1, 0, 0,
668 "Return the contents of @var{symbol}'s @dfn{function slot}.")
669 #define FUNC_NAME s_scm_symbol_fref
671 SCM_VALIDATE_SYMBOL (1,s
);
672 return SCM_SYMBOL_FUNC (s
);
677 SCM_DEFINE (scm_symbol_pref
, "symbol-pref", 1, 0, 0,
679 "Return the @dfn{property list} currently associated with @var{symbol}.")
680 #define FUNC_NAME s_scm_symbol_pref
682 SCM_VALIDATE_SYMBOL (1,s
);
683 return SCM_SYMBOL_PROPS (s
);
688 SCM_DEFINE (scm_symbol_fset_x
, "symbol-fset!", 2, 0, 0,
690 "Change the binding of @var{symbol}'s function slot.")
691 #define FUNC_NAME s_scm_symbol_fset_x
693 SCM_VALIDATE_SYMBOL (1,s
);
694 SCM_SET_SYMBOL_FUNC (s
, val
);
695 return SCM_UNSPECIFIED
;
700 SCM_DEFINE (scm_symbol_pset_x
, "symbol-pset!", 2, 0, 0,
702 "Change the binding of @var{symbol}'s property slot.")
703 #define FUNC_NAME s_scm_symbol_pset_x
705 SCM_VALIDATE_SYMBOL (1,s
);
707 SCM_SET_SYMBOL_PROPS (s
, val
);
709 return SCM_UNSPECIFIED
;
714 SCM_DEFINE (scm_symbol_hash
, "symbol-hash", 1, 0, 0,
716 "Return a hash value for @var{symbol}.")
717 #define FUNC_NAME s_scm_symbol_hash
719 SCM_VALIDATE_SYMBOL (1, symbol
);
720 return SCM_MAKINUM (SCM_SYMBOL_HASH (symbol
));
726 copy_and_prune_obarray (SCM from
, SCM to
)
729 int length
= SCM_VECTOR_LENGTH (from
);
730 for (i
= 0; i
< length
; ++i
)
732 SCM head
= SCM_VELTS (from
)[i
]; /* GC protection */
736 while (SCM_NIMP (ls
))
738 if (!SCM_UNBNDP (SCM_CDAR (ls
)))
740 *lloc
= scm_cons (SCM_CAR (ls
), SCM_EOL
);
741 lloc
= SCM_CDRLOC (*lloc
);
745 SCM_VELTS (to
)[i
] = res
;
750 SCM_DEFINE (scm_builtin_bindings
, "builtin-bindings", 0, 0, 0,
752 "Create and return a copy of the global symbol table, removing all\n"
754 #define FUNC_NAME s_scm_builtin_bindings
756 int length
= SCM_VECTOR_LENGTH (scm_symhash
);
757 SCM obarray
= scm_make_vector (SCM_MAKINUM (length
), SCM_EOL
);
758 copy_and_prune_obarray (scm_symhash
, obarray
);
764 #define MAX_PREFIX_LENGTH 30
766 static int gensym_counter
;
768 SCM_DEFINE (scm_gensym
, "gensym", 0, 1, 0,
770 "Create a new symbol with name constructed from a prefix and a counter value.\n"
771 "The string PREFIX can be specified as an optional argument.\n"
772 "Default prefix is @code{g}. The counter is increased by 1 at each call.\n"
773 "There is no provision for 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 PREFIX and a counter\n"
808 "value. The default prefix is @var{t}. The OBARRAY is specified as a\n"
809 "second optional argument. Default is the system obarray where all\n"
810 "normal symbols are interned. The counter is increased by 1 at each\n"
811 "call. There is no provision for resetting the counter.")
812 #define FUNC_NAME s_scm_gentemp
814 char buf
[MAX_PREFIX_LENGTH
+ SCM_INTBUFLEN
];
817 if (SCM_UNBNDP (prefix
))
824 SCM_VALIDATE_STRING (1, prefix
);
825 len
= SCM_STRING_LENGTH (prefix
);
826 if (len
> MAX_PREFIX_LENGTH
)
827 name
= SCM_MUST_MALLOC (MAX_PREFIX_LENGTH
+ SCM_INTBUFLEN
);
828 strncpy (name
, SCM_STRING_CHARS (prefix
), len
);
831 if (SCM_UNBNDP (obarray
))
832 obarray
= scm_symhash
;
834 SCM_ASSERT ((SCM_VECTORP (obarray
) || SCM_WVECTP (obarray
)),
839 n_digits
= scm_iint2str (gentemp_counter
++, 10, &name
[len
]);
840 while (!SCM_FALSEP (scm_intern_obarray_soft (name
,
845 SCM vcell
= scm_intern_obarray_soft (name
,
850 scm_must_free (name
);
851 return SCM_CAR (vcell
);
861 #ifndef SCM_MAGIC_SNARFER
862 #include "libguile/symbols.x"