1 /* Copyright (C) 1995,1996,1997,1998, 2000, 2001 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 */
47 #include "libguile/_scm.h"
48 #include "libguile/chars.h"
49 #include "libguile/eval.h"
50 #include "libguile/hash.h"
51 #include "libguile/smob.h"
52 #include "libguile/variable.h"
53 #include "libguile/alist.h"
54 #include "libguile/fluids.h"
55 #include "libguile/strings.h"
56 #include "libguile/vectors.h"
57 #include "libguile/hashtab.h"
58 #include "libguile/weaks.h"
59 #include "libguile/modules.h"
61 #include "libguile/validate.h"
62 #include "libguile/symbols.h"
73 SCM_DEFINE (scm_sys_symbols
, "%symbols", 0, 0, 0,
75 "Return the system symbol obarray.")
76 #define FUNC_NAME s_scm_sys_symbols
86 duplicate_string (const char * src
, unsigned long length
)
88 char * dst
= scm_must_malloc (length
+ 1, "duplicate_string");
89 memcpy (dst
, src
, length
);
101 scm_mem2symbol (const char *name
, scm_sizet len
)
103 scm_sizet raw_hash
= scm_string_hash ((const unsigned char *) name
, len
);
104 scm_sizet hash
= raw_hash
% SCM_VECTOR_LENGTH (symbols
);
107 /* Try to find the symbol in the symbols table */
111 for (l
= SCM_VELTS (symbols
) [hash
]; !SCM_NULLP (l
); l
= SCM_CDR (l
))
113 SCM sym
= SCM_CAAR (l
);
114 if (SCM_SYMBOL_HASH (sym
) == raw_hash
&& SCM_SYMBOL_LENGTH (sym
) == len
)
116 char *chrs
= SCM_SYMBOL_CHARS (sym
);
122 if (name
[i
] != chrs
[i
])
134 /* The symbol was not found - create it. */
140 SCM_NEWCELL2 (symbol
);
141 SCM_SET_SYMBOL_CHARS (symbol
, duplicate_string (name
, len
));
142 SCM_SET_SYMBOL_HASH (symbol
, raw_hash
);
143 SCM_SET_PROP_SLOTS (symbol
, scm_cons (SCM_BOOL_F
, SCM_EOL
));
144 SCM_SET_SYMBOL_LENGTH (symbol
, (long) len
);
146 cell
= scm_cons (symbol
, SCM_UNDEFINED
);
147 slot
= SCM_VELTS (symbols
) [hash
];
148 SCM_VELTS (symbols
) [hash
] = scm_cons (cell
, slot
);
156 scm_str2symbol (const char *str
)
158 return scm_mem2symbol (str
, strlen (str
));
163 * looks up the symbol in the symhash table.
167 scm_sym2vcell (SCM sym
, SCM thunk
, SCM definep
)
168 #define FUNC_NAME "scm_sym2vcell"
170 if (SCM_NIMP (thunk
))
174 if (SCM_EVAL_CLOSURE_P (thunk
))
175 /* Bypass evaluator in the standard case. */
176 var
= scm_eval_closure_lookup (thunk
, sym
, definep
);
178 var
= scm_apply (thunk
, sym
, scm_cons (definep
, scm_listofnull
));
180 if (SCM_FALSEP (var
))
182 else if (SCM_VARIABLEP (var
))
183 return SCM_VARVCELL (var
);
185 SCM_MISC_ERROR ("strangely interned symbol: ~S", SCM_LIST1 (sym
));
193 hash
= SCM_SYMBOL_HASH (sym
) % SCM_VECTOR_LENGTH (scm_symhash
);
194 for (lsym
= SCM_VELTS (scm_symhash
)[hash
]; SCM_NIMP (lsym
); lsym
= SCM_CDR (lsym
))
196 SCM z
= SCM_CAR (lsym
);
197 if (SCM_EQ_P (SCM_CAR (z
), sym
))
204 if (!SCM_FALSEP (definep
))
206 SCM cell
= scm_cons (sym
, SCM_UNDEFINED
);
207 SCM slot
= SCM_VELTS (scm_symhash
) [hash
];
209 SCM_VELTS (scm_symhash
) [hash
] = scm_cons (cell
, slot
);
225 * looks up the symbol in an arbitrary obarray.
229 scm_sym2ovcell_soft (SCM sym
, SCM obarray
)
232 scm_sizet hash
= SCM_SYMBOL_HASH (sym
) % SCM_VECTOR_LENGTH (obarray
);
234 for (lsym
= SCM_VELTS (obarray
)[hash
];
236 lsym
= SCM_CDR (lsym
))
239 if (SCM_EQ_P (SCM_CAR (z
), sym
))
251 scm_sym2ovcell (SCM sym
, SCM obarray
)
252 #define FUNC_NAME "scm_sym2ovcell"
255 answer
= scm_sym2ovcell_soft (sym
, obarray
);
256 if (!SCM_FALSEP (answer
))
258 SCM_MISC_ERROR ("uninterned symbol: ~S", SCM_LIST1 (sym
));
259 return SCM_UNSPECIFIED
; /* not reached */
264 /* Intern a symbol whose name is the LEN characters at NAME in OBARRAY.
266 OBARRAY should be a vector of lists, indexed by the name's hash
267 value, modulo OBARRAY's length. Each list has the form
268 ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the
269 value associated with that symbol (in the current module? in the
272 To "intern" a symbol means: if OBARRAY already contains a symbol by
273 that name, return its (SYMBOL . VALUE) pair; otherwise, create a
274 new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the
275 appropriate list of the OBARRAY, and return the pair.
277 If softness is non-zero, don't create a symbol if it isn't already
278 in OBARRAY; instead, just return #f.
280 If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and
281 return (SYMBOL . SCM_UNDEFINED). */
285 scm_intern_obarray_soft (const char *name
,scm_sizet len
,SCM obarray
,unsigned int softness
)
287 SCM symbol
= scm_mem2symbol (name
, len
);
288 scm_sizet raw_hash
= SCM_SYMBOL_HASH (symbol
);
292 if (SCM_FALSEP (obarray
))
297 return scm_cons (symbol
, SCM_UNDEFINED
);
300 hash
= raw_hash
% SCM_VECTOR_LENGTH (obarray
);
302 for (lsym
= SCM_VELTS (obarray
)[hash
]; SCM_NIMP (lsym
); lsym
= SCM_CDR (lsym
))
304 SCM a
= SCM_CAR (lsym
);
306 if (SCM_EQ_P (z
, symbol
))
316 SCM cell
= scm_cons (symbol
, SCM_UNDEFINED
);
317 SCM slot
= SCM_VELTS (obarray
) [hash
];
319 SCM_VELTS (obarray
) [hash
] = scm_cons (cell
, slot
);
327 scm_intern_obarray (const char *name
,scm_sizet len
,SCM obarray
)
329 return scm_intern_obarray_soft (name
, len
, obarray
, 0);
334 scm_intern (const char *name
,scm_sizet len
)
336 return scm_intern_obarray (name
, len
, scm_symhash
);
341 scm_intern0 (const char * name
)
343 return scm_intern (name
, strlen (name
));
347 /* Intern the symbol named NAME in scm_symhash, NAME is null-terminated. */
349 scm_sysintern0_no_module_lookup (const char *name
)
351 scm_sizet len
= strlen (name
);
354 easy_answer
= scm_intern_obarray_soft (name
, len
, scm_symhash
, 1);
355 if (SCM_NIMP (easy_answer
))
362 SCM symbol
= scm_mem2symbol (name
, len
);
363 scm_sizet raw_hash
= SCM_SYMBOL_HASH (symbol
);
364 scm_sizet hash
= raw_hash
% SCM_VECTOR_LENGTH (scm_symhash
);
365 SCM cell
= scm_cons (symbol
, SCM_UNDEFINED
);
366 SCM slot
= SCM_VELTS (scm_symhash
) [hash
];
368 SCM_VELTS (scm_symhash
) [hash
] = scm_cons (cell
, slot
);
374 /* Intern the symbol named NAME in scm_symhash, and give it the value
375 VAL. NAME is null-terminated. Use the current top_level lookup
376 closure to give NAME its value.
379 scm_sysintern (const char *name
, SCM val
)
381 SCM vcell
= scm_sysintern0 (name
);
382 SCM_SETCDR (vcell
, val
);
387 scm_sysintern0 (const char *name
)
390 if (scm_module_system_booted_p
391 && SCM_NIMP (lookup_proc
= SCM_TOP_LEVEL_LOOKUP_CLOSURE
))
393 SCM sym
= scm_str2symbol (name
);
394 SCM vcell
= scm_sym2vcell (sym
, lookup_proc
, SCM_BOOL_T
);
395 if (SCM_FALSEP (vcell
))
396 scm_misc_error ("sysintern0", "can't define variable", sym
);
400 return scm_sysintern0_no_module_lookup (name
);
403 /* Lookup the value of the symbol named by the nul-terminated string
404 NAME in the current module. */
406 scm_symbol_value0 (const char *name
)
408 /* This looks silly - we look up the symbol twice. But it is in
409 fact necessary given the current module system because the module
410 lookup closures are written in scheme which needs real symbols. */
411 SCM symbol
= scm_str2symbol (name
);
412 SCM vcell
= scm_sym2vcell (symbol
, SCM_TOP_LEVEL_LOOKUP_CLOSURE
, SCM_BOOL_F
);
413 if (SCM_FALSEP (vcell
))
414 return SCM_UNDEFINED
;
415 return SCM_CDR (vcell
);
419 SCM_DEFINE (scm_symbol_p
, "symbol?", 1, 0, 0,
421 "Returns @code{#t} if @var{obj} is a symbol, otherwise returns\n"
423 #define FUNC_NAME s_scm_symbol_p
425 return SCM_BOOL (SCM_SYMBOLP (obj
));
429 SCM_DEFINE (scm_symbol_to_string
, "symbol->string", 1, 0, 0,
431 "Returns the name of @var{symbol} as a string. If the symbol\n"
432 "was part of an object returned as the value of a literal\n"
433 "expression (section @pxref{Literal expressions,,,r4rs, The\n"
434 "Revised^4 Report on Scheme}) or by a call to the @code{read}\n"
435 "procedure, and its name contains alphabetic characters, then\n"
436 "the string returned will contain characters in the\n"
437 "implementation's preferred standard case---some implementations\n"
438 "will prefer upper case, others lower case. If the symbol was\n"
439 "returned by @code{string->symbol}, the case of characters in\n"
440 "the string returned will be the same as the case in the string\n"
441 "that was passed to @code{string->symbol}. It is an error to\n"
442 "apply mutation procedures like @code{string-set!} to strings\n"
443 "returned by this procedure. (r5rs)\n\n"
444 "The following examples assume that the implementation's\n"
445 "standard case is lower case:\n\n"
447 "(symbol->string 'flying-fish) @result{} \"flying-fish\"\n"
448 "(symbol->string 'Martin) @result{} \"martin\"\n"
450 " (string->symbol \"Malvina\")) @result{} \"Malvina\"\n"
452 #define FUNC_NAME s_scm_symbol_to_string
454 SCM_VALIDATE_SYMBOL (1, s
);
455 return scm_makfromstr (SCM_SYMBOL_CHARS (s
), SCM_SYMBOL_LENGTH (s
), 0);
460 SCM_DEFINE (scm_string_to_symbol
, "string->symbol", 1, 0, 0,
462 "Returns the symbol whose name is @var{string}. This procedure\n"
463 "can create symbols with names containing special characters or\n"
464 "letters in the non-standard case, but it is usually a bad idea\n"
465 "to create such because in some implementations of Scheme they\n"
466 "cannot be read as themselves. See @code{symbol->string}.\n\n"
467 "The following examples assume that the implementation's\n"
468 "standard case is lower case:\n\n"
470 "(eq? 'mISSISSIppi 'mississippi) @result{} #t\n"
471 "(string->symbol \"mISSISSIppi\") @result{} @r{the symbol with name \"mISSISSIppi\"}\n"
472 "(eq? 'bitBlt (string->symbol \"bitBlt\")) @result{} #f\n"
474 " (string->symbol (symbol->string 'JollyWog))) @result{} #t\n"
475 "(string=? \"K. Harper, M.D.\"\n"
477 " (string->symbol \"K. Harper, M.D.\"))) @result{}#t\n"
479 #define FUNC_NAME s_scm_string_to_symbol
481 SCM_VALIDATE_STRING (1, s
);
482 return scm_mem2symbol (SCM_STRING_CHARS (s
), SCM_STRING_LENGTH (s
));
487 SCM_DEFINE (scm_string_to_obarray_symbol
, "string->obarray-symbol", 2, 1, 0,
488 (SCM o
, SCM s
, SCM softp
),
489 "Intern a new symbol in @var{obarray}, a symbol table, with name\n"
491 "If @var{obarray} is @code{#f}, use the default system symbol table. If\n"
492 "@var{obarray} is @code{#t}, the symbol should not be interned in any\n"
493 "symbol table; merely return the pair (@var{symbol}\n"
494 ". @var{#<undefined>}).\n\n"
495 "The @var{soft?} argument determines whether new symbol table entries\n"
496 "should be created when the specified symbol is not already present in\n"
497 "@var{obarray}. If @var{soft?} is specified and is a true value, then\n"
498 "new entries should not be added for symbols not already present in the\n"
499 "table; instead, simply return @code{#f}.")
500 #define FUNC_NAME s_scm_string_to_obarray_symbol
506 SCM_VALIDATE_STRING (2, s
);
507 SCM_ASSERT (SCM_BOOLP (o
) || SCM_VECTORP (o
), o
, SCM_ARG1
, FUNC_NAME
);
509 softness
= (!SCM_UNBNDP (softp
) && !SCM_FALSEP(softp
));
510 /* iron out some screwy calling conventions */
513 else if (SCM_EQ_P (o
, SCM_BOOL_T
))
516 vcell
= scm_intern_obarray_soft (SCM_STRING_CHARS(s
),
517 SCM_STRING_LENGTH (s
),
520 if (SCM_FALSEP (vcell
))
522 answer
= SCM_CAR (vcell
);
527 SCM_DEFINE (scm_intern_symbol
, "intern-symbol", 2, 0, 0,
529 "Add a new symbol to @var{obarray} with name @var{string}, bound to an\n"
530 "unspecified initial value. The symbol table is not modified if a symbol\n"
531 "with this name is already present.")
532 #define FUNC_NAME s_scm_intern_symbol
535 SCM_VALIDATE_SYMBOL (2,s
);
538 SCM_VALIDATE_VECTOR (1,o
);
539 hval
= SCM_SYMBOL_HASH (s
) % SCM_VECTOR_LENGTH (o
);
540 /* If the symbol is already interned, simply return. */
545 for (lsym
= SCM_VELTS (o
)[hval
];
547 lsym
= SCM_CDR (lsym
))
549 sym
= SCM_CAR (lsym
);
550 if (SCM_EQ_P (SCM_CAR (sym
), s
))
553 return SCM_UNSPECIFIED
;
556 SCM_VELTS (o
)[hval
] =
557 scm_acons (s
, SCM_UNDEFINED
, SCM_VELTS (o
)[hval
]);
560 return SCM_UNSPECIFIED
;
564 SCM_DEFINE (scm_unintern_symbol
, "unintern-symbol", 2, 0, 0,
566 "Remove the symbol with name @var{string} from @var{obarray}. This\n"
567 "function returns @code{#t} if the symbol was present and @code{#f}\n"
569 #define FUNC_NAME s_scm_unintern_symbol
572 SCM_VALIDATE_SYMBOL (2,s
);
575 SCM_VALIDATE_VECTOR (1,o
);
576 hval
= SCM_SYMBOL_HASH (s
) % SCM_VECTOR_LENGTH (o
);
582 for (lsym
= SCM_VELTS (o
)[hval
], lsym_follow
= SCM_BOOL_F
;
584 lsym_follow
= lsym
, lsym
= SCM_CDR (lsym
))
586 sym
= SCM_CAR (lsym
);
587 if (SCM_EQ_P (SCM_CAR (sym
), s
))
589 /* Found the symbol to unintern. */
590 if (SCM_FALSEP (lsym_follow
))
591 SCM_VELTS(o
)[hval
] = lsym
;
593 SCM_SETCDR (lsym_follow
, SCM_CDR(lsym
));
604 SCM_DEFINE (scm_symbol_binding
, "symbol-binding", 2, 0, 0,
606 "Look up in @var{obarray} the symbol whose name is @var{string}, and\n"
607 "return the value to which it is bound. If @var{obarray} is @code{#f},\n"
608 "use the global symbol table. If @var{string} is not interned in\n"
609 "@var{obarray}, an error is signalled.")
610 #define FUNC_NAME s_scm_symbol_binding
613 SCM_VALIDATE_SYMBOL (2,s
);
616 SCM_VALIDATE_VECTOR (1,o
);
617 vcell
= scm_sym2ovcell (s
, o
);
618 return SCM_CDR(vcell
);
623 SCM_DEFINE (scm_symbol_interned_p
, "symbol-interned?", 2, 0, 0,
625 "Return @var{#t} if @var{obarray} contains a symbol with name\n"
626 "@var{string}, and @var{#f} otherwise.")
627 #define FUNC_NAME s_scm_symbol_interned_p
630 SCM_VALIDATE_SYMBOL (2,s
);
633 SCM_VALIDATE_VECTOR (1,o
);
634 vcell
= scm_sym2ovcell_soft (s
, o
);
635 return (SCM_NIMP(vcell
)
642 SCM_DEFINE (scm_symbol_bound_p
, "symbol-bound?", 2, 0, 0,
644 "Return @var{#t} if @var{obarray} contains a symbol with name\n"
645 "@var{string} bound to a defined value. This differs from\n"
646 "@var{symbol-interned?} in that the mere mention of a symbol usually causes\n"
647 "it to be interned; @code{symbol-bound?} determines whether a symbol has\n"
648 "been given any meaningful value.")
649 #define FUNC_NAME s_scm_symbol_bound_p
652 SCM_VALIDATE_SYMBOL (2,s
);
655 SCM_VALIDATE_VECTOR (1,o
);
656 vcell
= scm_sym2ovcell_soft (s
, o
);
657 return SCM_BOOL (SCM_NIMP (vcell
) && !SCM_UNBNDP (SCM_CDR (vcell
)));
662 SCM_DEFINE (scm_symbol_set_x
, "symbol-set!", 3, 0, 0,
663 (SCM o
, SCM s
, SCM v
),
664 "Find the symbol in @var{obarray} whose name is @var{string}, and rebind\n"
665 "it to @var{value}. An error is signalled if @var{string} is not present\n"
667 #define FUNC_NAME s_scm_symbol_set_x
670 SCM_VALIDATE_SYMBOL (2,s
);
673 SCM_VALIDATE_VECTOR (1,o
);
674 vcell
= scm_sym2ovcell (s
, o
);
675 SCM_SETCDR (vcell
, v
);
676 return SCM_UNSPECIFIED
;
681 SCM_DEFINE (scm_symbol_fref
, "symbol-fref", 1, 0, 0,
683 "Return the contents of @var{symbol}'s @dfn{function slot}.")
684 #define FUNC_NAME s_scm_symbol_fref
686 SCM_VALIDATE_SYMBOL (1,s
);
687 return SCM_SYMBOL_FUNC (s
);
692 SCM_DEFINE (scm_symbol_pref
, "symbol-pref", 1, 0, 0,
694 "Return the @dfn{property list} currently associated with @var{symbol}.")
695 #define FUNC_NAME s_scm_symbol_pref
697 SCM_VALIDATE_SYMBOL (1,s
);
698 return SCM_SYMBOL_PROPS (s
);
703 SCM_DEFINE (scm_symbol_fset_x
, "symbol-fset!", 2, 0, 0,
705 "Change the binding of @var{symbol}'s function slot.")
706 #define FUNC_NAME s_scm_symbol_fset_x
708 SCM_VALIDATE_SYMBOL (1,s
);
709 SCM_SET_SYMBOL_FUNC (s
, val
);
710 return SCM_UNSPECIFIED
;
715 SCM_DEFINE (scm_symbol_pset_x
, "symbol-pset!", 2, 0, 0,
717 "Change the binding of @var{symbol}'s property slot.")
718 #define FUNC_NAME s_scm_symbol_pset_x
720 SCM_VALIDATE_SYMBOL (1,s
);
722 SCM_SET_SYMBOL_PROPS (s
, val
);
724 return SCM_UNSPECIFIED
;
729 SCM_DEFINE (scm_symbol_hash
, "symbol-hash", 1, 0, 0,
731 "Return a hash value for @var{symbol}.")
732 #define FUNC_NAME s_scm_symbol_hash
734 SCM_VALIDATE_SYMBOL (1, symbol
);
735 return SCM_MAKINUM (SCM_SYMBOL_HASH (symbol
));
741 copy_and_prune_obarray (SCM from
, SCM to
)
744 int length
= SCM_VECTOR_LENGTH (from
);
745 for (i
= 0; i
< length
; ++i
)
747 SCM head
= SCM_VELTS (from
)[i
]; /* GC protection */
751 while (SCM_NIMP (ls
))
753 if (!SCM_UNBNDP (SCM_CDAR (ls
)))
755 *lloc
= scm_cons (SCM_CAR (ls
), SCM_EOL
);
756 lloc
= SCM_CDRLOC (*lloc
);
760 SCM_VELTS (to
)[i
] = res
;
765 SCM_DEFINE (scm_builtin_bindings
, "builtin-bindings", 0, 0, 0,
767 "Create and return a copy of the global symbol table, removing all\n"
769 #define FUNC_NAME s_scm_builtin_bindings
771 int length
= SCM_VECTOR_LENGTH (scm_symhash
);
772 SCM obarray
= scm_c_make_hash_table (length
);
773 copy_and_prune_obarray (scm_symhash
, obarray
);
779 #define MAX_PREFIX_LENGTH 30
781 static int gensym_counter
;
783 SCM_DEFINE (scm_gensym
, "gensym", 0, 1, 0,
785 "Create a new symbol with a name constructed from a prefix and\n"
786 "a counter value. The string @var{prefix} can be specified as\n"
787 "an optional argument. Default prefix is @code{g}. The counter\n"
788 "is increased by 1 at each call. There is no provision for\n"
789 "resetting the counter.")
790 #define FUNC_NAME s_scm_gensym
792 char buf
[MAX_PREFIX_LENGTH
+ SCM_INTBUFLEN
];
795 if (SCM_UNBNDP (prefix
))
802 SCM_VALIDATE_STRING (1, prefix
);
803 len
= SCM_STRING_LENGTH (prefix
);
804 if (len
> MAX_PREFIX_LENGTH
)
805 name
= SCM_MUST_MALLOC (MAX_PREFIX_LENGTH
+ SCM_INTBUFLEN
);
806 strncpy (name
, SCM_STRING_CHARS (prefix
), len
);
809 int n_digits
= scm_iint2str (gensym_counter
++, 10, &name
[len
]);
810 SCM res
= scm_mem2symbol (name
, len
+ n_digits
);
812 scm_must_free (name
);
818 static int gentemp_counter
;
820 SCM_DEFINE (scm_gentemp
, "gentemp", 0, 2, 0,
821 (SCM prefix
, SCM obarray
),
822 "Create a new symbol with a name unique in an obarray.\n"
823 "The name is constructed from an optional string @var{prefix}\n"
824 "and a counter value. The default prefix is @code{t}. The\n"
825 "@var{obarray} is specified as a second optional argument.\n"
826 "Default is the system obarray where all normal symbols are\n"
827 "interned. The counter is increased by 1 at each\n"
828 "call. There is no provision for resetting the counter.")
829 #define FUNC_NAME s_scm_gentemp
831 char buf
[MAX_PREFIX_LENGTH
+ SCM_INTBUFLEN
];
834 if (SCM_UNBNDP (prefix
))
841 SCM_VALIDATE_STRING (1, prefix
);
842 len
= SCM_STRING_LENGTH (prefix
);
843 if (len
> MAX_PREFIX_LENGTH
)
844 name
= SCM_MUST_MALLOC (MAX_PREFIX_LENGTH
+ SCM_INTBUFLEN
);
845 strncpy (name
, SCM_STRING_CHARS (prefix
), len
);
848 if (SCM_UNBNDP (obarray
))
849 obarray
= scm_symhash
;
851 SCM_ASSERT ((SCM_VECTORP (obarray
) || SCM_WVECTP (obarray
)),
856 n_digits
= scm_iint2str (gentemp_counter
++, 10, &name
[len
]);
857 while (!SCM_FALSEP (scm_intern_obarray_soft (name
,
862 SCM vcell
= scm_intern_obarray_soft (name
,
867 scm_must_free (name
);
868 return SCM_CAR (vcell
);
875 scm_symbols_prehistory ()
877 symbols
= scm_make_weak_key_hash_table (SCM_MAKINUM (1009));
878 scm_permanent_object (symbols
);
887 #ifndef SCM_MAGIC_SNARFER
888 #include "libguile/symbols.x"