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"
75 duplicate_string (const char * src
, unsigned long length
)
77 char * dst
= scm_must_malloc (length
+ 1, "duplicate_string");
78 memcpy (dst
, src
, length
);
90 scm_mem2symbol (const char *name
, scm_sizet len
)
92 scm_sizet raw_hash
= scm_string_hash ((const unsigned char *) name
, len
);
93 scm_sizet hash
= raw_hash
% SCM_VECTOR_LENGTH (symbols
);
96 /* Try to find the symbol in the symbols table */
100 for (l
= SCM_VELTS (symbols
) [hash
]; !SCM_NULLP (l
); l
= SCM_CDR (l
))
102 SCM sym
= SCM_CAAR (l
);
103 if (SCM_SYMBOL_HASH (sym
) == raw_hash
&& SCM_SYMBOL_LENGTH (sym
) == len
)
105 char *chrs
= SCM_SYMBOL_CHARS (sym
);
111 if (name
[i
] != chrs
[i
])
122 /* The symbol was not found - create it. */
128 SCM_NEWCELL2 (symbol
);
129 SCM_SET_SYMBOL_CHARS (symbol
, duplicate_string (name
, len
));
130 SCM_SET_SYMBOL_HASH (symbol
, raw_hash
);
131 SCM_SET_PROP_SLOTS (symbol
, scm_cons (SCM_BOOL_F
, SCM_EOL
));
132 SCM_SET_SYMBOL_LENGTH (symbol
, (long) len
);
134 cell
= scm_cons (symbol
, SCM_UNDEFINED
);
135 slot
= SCM_VELTS (symbols
) [hash
];
136 SCM_VELTS (symbols
) [hash
] = scm_cons (cell
, slot
);
144 scm_str2symbol (const char *str
)
146 return scm_mem2symbol (str
, strlen (str
));
151 * looks up the symbol in the symhash table.
155 scm_sym2vcell (SCM sym
, SCM thunk
, SCM definep
)
157 if (SCM_NIMP (thunk
))
161 if (SCM_EVAL_CLOSURE_P (thunk
))
162 /* Bypass evaluator in the standard case. */
163 var
= scm_eval_closure_lookup (thunk
, sym
, definep
);
165 var
= scm_apply (thunk
, sym
, scm_cons (definep
, scm_listofnull
));
167 if (SCM_FALSEP (var
))
169 else if (SCM_VARIABLEP (var
))
170 return SCM_VARVCELL (var
);
172 return scm_wta (sym
, "strangely interned symbol? ", "");
180 hash
= SCM_SYMBOL_HASH (sym
) % SCM_VECTOR_LENGTH (scm_symhash
);
181 for (lsym
= SCM_VELTS (scm_symhash
)[hash
]; SCM_NIMP (lsym
); lsym
= SCM_CDR (lsym
))
183 SCM z
= SCM_CAR (lsym
);
184 if (SCM_EQ_P (SCM_CAR (z
), sym
))
191 if (!SCM_FALSEP (definep
))
193 SCM cell
= scm_cons (sym
, SCM_UNDEFINED
);
194 SCM slot
= SCM_VELTS (scm_symhash
) [hash
];
196 SCM_VELTS (scm_symhash
) [hash
] = scm_cons (cell
, slot
);
210 * looks up the symbol in an arbitrary obarray.
214 scm_sym2ovcell_soft (SCM sym
, SCM obarray
)
217 scm_sizet hash
= SCM_SYMBOL_HASH (sym
) % SCM_VECTOR_LENGTH (obarray
);
219 for (lsym
= SCM_VELTS (obarray
)[hash
];
221 lsym
= SCM_CDR (lsym
))
224 if (SCM_EQ_P (SCM_CAR (z
), sym
))
236 scm_sym2ovcell (SCM sym
, SCM obarray
)
239 answer
= scm_sym2ovcell_soft (sym
, obarray
);
240 if (!SCM_FALSEP (answer
))
242 scm_wta (sym
, "uninterned symbol? ", "");
243 return SCM_UNSPECIFIED
; /* not reached */
246 /* Intern a symbol whose name is the LEN characters at NAME in OBARRAY.
248 OBARRAY should be a vector of lists, indexed by the name's hash
249 value, modulo OBARRAY's length. Each list has the form
250 ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the
251 value associated with that symbol (in the current module? in the
254 To "intern" a symbol means: if OBARRAY already contains a symbol by
255 that name, return its (SYMBOL . VALUE) pair; otherwise, create a
256 new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the
257 appropriate list of the OBARRAY, and return the pair.
259 If softness is non-zero, don't create a symbol if it isn't already
260 in OBARRAY; instead, just return #f.
262 If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and
263 return (SYMBOL . SCM_UNDEFINED). */
267 scm_intern_obarray_soft (const char *name
,scm_sizet len
,SCM obarray
,unsigned int softness
)
269 SCM symbol
= scm_mem2symbol (name
, len
);
270 scm_sizet raw_hash
= SCM_SYMBOL_HASH (symbol
);
274 if (SCM_FALSEP (obarray
))
279 return scm_cons (symbol
, SCM_UNDEFINED
);
282 hash
= raw_hash
% SCM_VECTOR_LENGTH (obarray
);
284 for (lsym
= SCM_VELTS (obarray
)[hash
]; SCM_NIMP (lsym
); lsym
= SCM_CDR (lsym
))
286 SCM a
= SCM_CAR (lsym
);
288 if (SCM_EQ_P (z
, symbol
))
298 SCM cell
= scm_cons (symbol
, SCM_UNDEFINED
);
299 SCM slot
= SCM_VELTS (obarray
) [hash
];
301 SCM_VELTS (obarray
) [hash
] = scm_cons (cell
, slot
);
309 scm_intern_obarray (const char *name
,scm_sizet len
,SCM obarray
)
311 return scm_intern_obarray_soft (name
, len
, obarray
, 0);
316 scm_intern (const char *name
,scm_sizet len
)
318 return scm_intern_obarray (name
, len
, scm_symhash
);
323 scm_intern0 (const char * name
)
325 return scm_intern (name
, strlen (name
));
329 /* Intern the symbol named NAME in scm_symhash, NAME is null-terminated. */
331 scm_sysintern0_no_module_lookup (const char *name
)
333 scm_sizet len
= strlen (name
);
336 easy_answer
= scm_intern_obarray_soft (name
, len
, scm_symhash
, 1);
337 if (SCM_NIMP (easy_answer
))
344 SCM symbol
= scm_mem2symbol (name
, len
);
345 scm_sizet raw_hash
= SCM_SYMBOL_HASH (symbol
);
346 scm_sizet hash
= raw_hash
% SCM_VECTOR_LENGTH (scm_symhash
);
347 SCM cell
= scm_cons (symbol
, SCM_UNDEFINED
);
348 SCM slot
= SCM_VELTS (scm_symhash
) [hash
];
350 SCM_VELTS (scm_symhash
) [hash
] = scm_cons (cell
, slot
);
356 /* Intern the symbol named NAME in scm_symhash, and give it the value
357 VAL. NAME is null-terminated. Use the current top_level lookup
358 closure to give NAME its value.
361 scm_sysintern (const char *name
, SCM val
)
363 SCM vcell
= scm_sysintern0 (name
);
364 SCM_SETCDR (vcell
, val
);
369 scm_sysintern0 (const char *name
)
372 if (scm_module_system_booted_p
373 && SCM_NIMP (lookup_proc
= SCM_TOP_LEVEL_LOOKUP_CLOSURE
))
375 SCM sym
= scm_str2symbol (name
);
376 SCM vcell
= scm_sym2vcell (sym
, lookup_proc
, SCM_BOOL_T
);
377 if (SCM_FALSEP (vcell
))
378 scm_misc_error ("sysintern0", "can't define variable", sym
);
382 return scm_sysintern0_no_module_lookup (name
);
385 /* Lookup the value of the symbol named by the nul-terminated string
386 NAME in the current module. */
388 scm_symbol_value0 (const char *name
)
390 /* This looks silly - we look up the symbol twice. But it is in
391 fact necessary given the current module system because the module
392 lookup closures are written in scheme which needs real symbols. */
393 SCM symbol
= scm_str2symbol (name
);
394 SCM vcell
= scm_sym2vcell (symbol
, SCM_TOP_LEVEL_LOOKUP_CLOSURE
, SCM_BOOL_F
);
395 if (SCM_FALSEP (vcell
))
396 return SCM_UNDEFINED
;
397 return SCM_CDR (vcell
);
401 SCM_DEFINE (scm_symbol_p
, "symbol?", 1, 0, 0,
403 "Returns @t{#t} if @var{obj} is a symbol, otherwise returns @t{#f}. (r5rs)")
404 #define FUNC_NAME s_scm_symbol_p
406 return SCM_BOOL (SCM_SYMBOLP (obj
));
410 SCM_DEFINE (scm_symbol_to_string
, "symbol->string", 1, 0, 0,
412 "Returns the name of @var{symbol} as a string. If the symbol was part of\n"
413 "an object returned as the value of a literal expression (section\n"
414 "@pxref{Literal expressions,,,r4rs, The Revised^4 Report on Scheme}) or\n"
415 "by a call to the @samp{read} procedure, and its name contains alphabetic\n"
416 "characters, then the string returned will contain characters in the\n"
417 "implementation's preferred standard case---some implementations will\n"
418 "prefer upper case, others lower case. If the symbol was returned by\n"
419 "@samp{string->symbol}, the case of characters in the string returned\n"
420 "will be the same as the case in the string that was passed to\n"
421 "@samp{string->symbol}. It is an error to apply mutation procedures like\n"
422 "@code{string-set!} to strings returned by this procedure. (r5rs)\n\n"
423 "The following examples assume that the implementation's standard case is\n"
426 "@t{(symbol->string 'flying-fish) \n"
427 " ==> \"flying-fish\"\n"
428 "(symbol->string 'Martin) ==> \"martin\"\n"
430 " (string->symbol \"Malvina\")) \n"
434 #define FUNC_NAME s_scm_symbol_to_string
436 SCM_VALIDATE_SYMBOL (1, s
);
437 return scm_makfromstr (SCM_SYMBOL_CHARS (s
), SCM_SYMBOL_LENGTH (s
), 0);
442 SCM_DEFINE (scm_string_to_symbol
, "string->symbol", 1, 0, 0,
444 "Returns the symbol whose name is @var{string}. This procedure can\n"
445 "create symbols with names containing special characters or letters in\n"
446 "the non-standard case, but it is usually a bad idea to create such\n"
447 "symbols because in some implementations of Scheme they cannot be read as\n"
448 "themselves. See @samp{symbol->string}.\n\n"
449 "The following examples assume that the implementation's standard case is\n"
452 "@t{(eq? 'mISSISSIppi 'mississippi) \n"
454 "(string->symbol \"mISSISSIppi\") \n"
456 " @r{}the symbol with name \"mISSISSIppi\"\n"
457 "(eq? 'bitBlt (string->symbol \"bitBlt\")) \n"
461 " (symbol->string 'JollyWog))) \n"
463 "(string=? \"K. Harper, M.D.\"\n"
465 " (string->symbol \"K. Harper, M.D.\"))) \n"
469 #define FUNC_NAME s_scm_string_to_symbol
471 SCM_VALIDATE_STRING (1, s
);
472 return scm_mem2symbol (SCM_STRING_CHARS (s
), SCM_STRING_LENGTH (s
));
477 SCM_DEFINE (scm_string_to_obarray_symbol
, "string->obarray-symbol", 2, 1, 0,
478 (SCM o
, SCM s
, SCM softp
),
479 "Intern a new symbol in @var{obarray}, a symbol table, with name\n"
481 "If @var{obarray} is @code{#f}, use the default system symbol table. If\n"
482 "@var{obarray} is @code{#t}, the symbol should not be interned in any\n"
483 "symbol table; merely return the pair (@var{symbol}\n"
484 ". @var{#<undefined>}).\n\n"
485 "The @var{soft?} argument determines whether new symbol table entries\n"
486 "should be created when the specified symbol is not already present in\n"
487 "@var{obarray}. If @var{soft?} is specified and is a true value, then\n"
488 "new entries should not be added for symbols not already present in the\n"
489 "table; instead, simply return @code{#f}.")
490 #define FUNC_NAME s_scm_string_to_obarray_symbol
496 SCM_VALIDATE_STRING (2, s
);
497 SCM_ASSERT (SCM_BOOLP (o
) || SCM_VECTORP (o
), o
, SCM_ARG1
, FUNC_NAME
);
499 softness
= (!SCM_UNBNDP (softp
) && !SCM_FALSEP(softp
));
500 /* iron out some screwy calling conventions */
503 else if (SCM_EQ_P (o
, SCM_BOOL_T
))
506 vcell
= scm_intern_obarray_soft (SCM_STRING_CHARS(s
),
507 SCM_STRING_LENGTH (s
),
510 if (SCM_FALSEP (vcell
))
512 answer
= SCM_CAR (vcell
);
517 SCM_DEFINE (scm_intern_symbol
, "intern-symbol", 2, 0, 0,
519 "Add a new symbol to @var{obarray} with name @var{string}, bound to an\n"
520 "unspecified initial value. The symbol table is not modified if a symbol\n"
521 "with this name is already present.")
522 #define FUNC_NAME s_scm_intern_symbol
525 SCM_VALIDATE_SYMBOL (2,s
);
528 SCM_VALIDATE_VECTOR (1,o
);
529 hval
= SCM_SYMBOL_HASH (s
) % SCM_VECTOR_LENGTH (o
);
530 /* If the symbol is already interned, simply return. */
535 for (lsym
= SCM_VELTS (o
)[hval
];
537 lsym
= SCM_CDR (lsym
))
539 sym
= SCM_CAR (lsym
);
540 if (SCM_EQ_P (SCM_CAR (sym
), s
))
543 return SCM_UNSPECIFIED
;
546 SCM_VELTS (o
)[hval
] =
547 scm_acons (s
, SCM_UNDEFINED
, SCM_VELTS (o
)[hval
]);
550 return SCM_UNSPECIFIED
;
554 SCM_DEFINE (scm_unintern_symbol
, "unintern-symbol", 2, 0, 0,
556 "Remove the symbol with name @var{string} from @var{obarray}. This\n"
557 "function returns @code{#t} if the symbol was present and @code{#f}\n"
559 #define FUNC_NAME s_scm_unintern_symbol
562 SCM_VALIDATE_SYMBOL (2,s
);
565 SCM_VALIDATE_VECTOR (1,o
);
566 hval
= SCM_SYMBOL_HASH (s
) % SCM_VECTOR_LENGTH (o
);
572 for (lsym
= SCM_VELTS (o
)[hval
], lsym_follow
= SCM_BOOL_F
;
574 lsym_follow
= lsym
, lsym
= SCM_CDR (lsym
))
576 sym
= SCM_CAR (lsym
);
577 if (SCM_EQ_P (SCM_CAR (sym
), s
))
579 /* Found the symbol to unintern. */
580 if (SCM_FALSEP (lsym_follow
))
581 SCM_VELTS(o
)[hval
] = lsym
;
583 SCM_SETCDR (lsym_follow
, SCM_CDR(lsym
));
594 SCM_DEFINE (scm_symbol_binding
, "symbol-binding", 2, 0, 0,
596 "Look up in @var{obarray} the symbol whose name is @var{string}, and\n"
597 "return the value to which it is bound. If @var{obarray} is @code{#f},\n"
598 "use the global symbol table. If @var{string} is not interned in\n"
599 "@var{obarray}, an error is signalled.")
600 #define FUNC_NAME s_scm_symbol_binding
603 SCM_VALIDATE_SYMBOL (2,s
);
606 SCM_VALIDATE_VECTOR (1,o
);
607 vcell
= scm_sym2ovcell (s
, o
);
608 return SCM_CDR(vcell
);
613 SCM_DEFINE (scm_symbol_interned_p
, "symbol-interned?", 2, 0, 0,
615 "Return @var{#t} if @var{obarray} contains a symbol with name\n"
616 "@var{string}, and @var{#f} otherwise.")
617 #define FUNC_NAME s_scm_symbol_interned_p
620 SCM_VALIDATE_SYMBOL (2,s
);
623 SCM_VALIDATE_VECTOR (1,o
);
624 vcell
= scm_sym2ovcell_soft (s
, o
);
625 return (SCM_NIMP(vcell
)
632 SCM_DEFINE (scm_symbol_bound_p
, "symbol-bound?", 2, 0, 0,
634 "Return @var{#t} if @var{obarray} contains a symbol with name\n"
635 "@var{string} bound to a defined value. This differs from\n"
636 "@var{symbol-interned?} in that the mere mention of a symbol usually causes\n"
637 "it to be interned; @code{symbol-bound?} determines whether a symbol has\n"
638 "been given any meaningful value.")
639 #define FUNC_NAME s_scm_symbol_bound_p
642 SCM_VALIDATE_SYMBOL (2,s
);
645 SCM_VALIDATE_VECTOR (1,o
);
646 vcell
= scm_sym2ovcell_soft (s
, o
);
647 return SCM_BOOL (SCM_NIMP (vcell
) && !SCM_UNBNDP (SCM_CDR (vcell
)));
652 SCM_DEFINE (scm_symbol_set_x
, "symbol-set!", 3, 0, 0,
653 (SCM o
, SCM s
, SCM v
),
654 "Find the symbol in @var{obarray} whose name is @var{string}, and rebind\n"
655 "it to @var{value}. An error is signalled if @var{string} is not present\n"
657 #define FUNC_NAME s_scm_symbol_set_x
660 SCM_VALIDATE_SYMBOL (2,s
);
663 SCM_VALIDATE_VECTOR (1,o
);
664 vcell
= scm_sym2ovcell (s
, o
);
665 SCM_SETCDR (vcell
, v
);
666 return SCM_UNSPECIFIED
;
671 SCM_DEFINE (scm_symbol_fref
, "symbol-fref", 1, 0, 0,
673 "Return the contents of @var{symbol}'s @dfn{function slot}.")
674 #define FUNC_NAME s_scm_symbol_fref
676 SCM_VALIDATE_SYMBOL (1,s
);
677 return SCM_SYMBOL_FUNC (s
);
682 SCM_DEFINE (scm_symbol_pref
, "symbol-pref", 1, 0, 0,
684 "Return the @dfn{property list} currently associated with @var{symbol}.")
685 #define FUNC_NAME s_scm_symbol_pref
687 SCM_VALIDATE_SYMBOL (1,s
);
688 return SCM_SYMBOL_PROPS (s
);
693 SCM_DEFINE (scm_symbol_fset_x
, "symbol-fset!", 2, 0, 0,
695 "Change the binding of @var{symbol}'s function slot.")
696 #define FUNC_NAME s_scm_symbol_fset_x
698 SCM_VALIDATE_SYMBOL (1,s
);
699 SCM_SET_SYMBOL_FUNC (s
, val
);
700 return SCM_UNSPECIFIED
;
705 SCM_DEFINE (scm_symbol_pset_x
, "symbol-pset!", 2, 0, 0,
707 "Change the binding of @var{symbol}'s property slot.")
708 #define FUNC_NAME s_scm_symbol_pset_x
710 SCM_VALIDATE_SYMBOL (1,s
);
712 SCM_SET_SYMBOL_PROPS (s
, val
);
714 return SCM_UNSPECIFIED
;
719 SCM_DEFINE (scm_symbol_hash
, "symbol-hash", 1, 0, 0,
721 "Return a hash value for @var{symbol}.")
722 #define FUNC_NAME s_scm_symbol_hash
724 SCM_VALIDATE_SYMBOL (1, symbol
);
725 return SCM_MAKINUM (SCM_SYMBOL_HASH (symbol
));
731 copy_and_prune_obarray (SCM from
, SCM to
)
734 int length
= SCM_VECTOR_LENGTH (from
);
735 for (i
= 0; i
< length
; ++i
)
737 SCM head
= SCM_VELTS (from
)[i
]; /* GC protection */
741 while (SCM_NIMP (ls
))
743 if (!SCM_UNBNDP (SCM_CDAR (ls
)))
745 *lloc
= scm_cons (SCM_CAR (ls
), SCM_EOL
);
746 lloc
= SCM_CDRLOC (*lloc
);
750 SCM_VELTS (to
)[i
] = res
;
755 SCM_DEFINE (scm_builtin_bindings
, "builtin-bindings", 0, 0, 0,
757 "Create and return a copy of the global symbol table, removing all\n"
759 #define FUNC_NAME s_scm_builtin_bindings
761 int length
= SCM_VECTOR_LENGTH (scm_symhash
);
762 SCM obarray
= scm_make_vector (SCM_MAKINUM (length
), SCM_EOL
);
763 copy_and_prune_obarray (scm_symhash
, obarray
);
769 #define MAX_PREFIX_LENGTH 30
771 static int gensym_counter
;
773 SCM_DEFINE (scm_gensym
, "gensym", 0, 1, 0,
775 "Create a new symbol with name constructed from a prefix and a counter value.\n"
776 "The string PREFIX can be specified as an optional argument.\n"
777 "Default prefix is @code{g}. The counter is increased by 1 at each call.\n"
778 "There is no provision for resetting the counter.")
779 #define FUNC_NAME s_scm_gensym
781 char buf
[MAX_PREFIX_LENGTH
+ SCM_INTBUFLEN
];
784 if (SCM_UNBNDP (prefix
))
791 SCM_VALIDATE_STRING (1, prefix
);
792 len
= SCM_STRING_LENGTH (prefix
);
793 if (len
> MAX_PREFIX_LENGTH
)
794 name
= SCM_MUST_MALLOC (MAX_PREFIX_LENGTH
+ SCM_INTBUFLEN
);
795 strncpy (name
, SCM_STRING_CHARS (prefix
), len
);
798 int n_digits
= scm_iint2str (gensym_counter
++, 10, &name
[len
]);
799 SCM res
= scm_mem2symbol (name
, len
+ n_digits
);
801 scm_must_free (name
);
807 static int gentemp_counter
;
809 SCM_DEFINE (scm_gentemp
, "gentemp", 0, 2, 0,
810 (SCM prefix
, SCM obarray
),
811 "Create a new symbol with a name unique in an obarray.\n"
812 "The name is constructed from an optional string PREFIX and a counter\n"
813 "value. The default prefix is @var{t}. The OBARRAY is specified as a\n"
814 "second optional argument. Default is the system obarray where all\n"
815 "normal symbols are interned. The counter is increased by 1 at each\n"
816 "call. There is no provision for resetting the counter.")
817 #define FUNC_NAME s_scm_gentemp
819 char buf
[MAX_PREFIX_LENGTH
+ SCM_INTBUFLEN
];
822 if (SCM_UNBNDP (prefix
))
829 SCM_VALIDATE_STRING (1, prefix
);
830 len
= SCM_STRING_LENGTH (prefix
);
831 if (len
> MAX_PREFIX_LENGTH
)
832 name
= SCM_MUST_MALLOC (MAX_PREFIX_LENGTH
+ SCM_INTBUFLEN
);
833 strncpy (name
, SCM_STRING_CHARS (prefix
), len
);
836 if (SCM_UNBNDP (obarray
))
837 obarray
= scm_symhash
;
839 SCM_ASSERT ((SCM_VECTORP (obarray
) || SCM_WVECTP (obarray
)),
844 n_digits
= scm_iint2str (gentemp_counter
++, 10, &name
[len
]);
845 while (!SCM_FALSEP (scm_intern_obarray_soft (name
,
850 SCM vcell
= scm_intern_obarray_soft (name
,
855 scm_must_free (name
);
856 return SCM_CAR (vcell
);
863 scm_symbols_prehistory ()
865 symbols
= scm_make_weak_key_hash_table (SCM_MAKINUM (277));
866 scm_permanent_object (symbols
);
875 #ifndef SCM_MAGIC_SNARFER
876 #include "libguile/symbols.x"