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/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/weaks.h"
58 #include "libguile/modules.h"
60 #include "libguile/validate.h"
61 #include "libguile/symbols.h"
69 /* NUM_HASH_BUCKETS is the number of symbol scm_hash table buckets.
71 #define NUM_HASH_BUCKETS 137
76 duplicate_string (const char * src
, unsigned long length
)
78 char * dst
= scm_must_malloc (length
+ 1, "duplicate_string");
79 memcpy (dst
, src
, length
+ 1);
90 scm_string_hash (const unsigned char *str
, scm_sizet len
)
95 unsigned long h
= 264;
97 h
= (h
<< 8) + ((unsigned) (scm_downcase (str
[h
% len
])));
105 h
= (h
<< 8) + ((unsigned) (scm_downcase (str
[--i
])));
111 int scm_symhash_dim
= NUM_HASH_BUCKETS
;
115 * looks up the symbol in the symhash table.
119 scm_sym2vcell (SCM sym
, SCM thunk
, SCM definep
)
121 if (SCM_NIMP (thunk
))
125 if (SCM_EVAL_CLOSURE_P (thunk
))
126 /* Bypass evaluator in the standard case. */
127 var
= scm_eval_closure_lookup (thunk
, sym
, definep
);
129 var
= scm_apply (thunk
, sym
, scm_cons (definep
, scm_listofnull
));
131 if (SCM_FALSEP (var
))
135 if (SCM_IMP(var
) || !SCM_VARIABLEP (var
))
136 scm_wta (sym
, "strangely interned symbol? ", "");
137 return SCM_VARVCELL (var
);
146 = scm_string_hash (SCM_UCHARS (sym
), SCM_LENGTH (sym
)) % scm_symhash_dim
;
149 for (lsym
= SCM_VELTS (scm_symhash
)[hash
]; SCM_NIMP (lsym
); lsym
= SCM_CDR (lsym
))
152 if (SCM_EQ_P (SCM_CAR (z
), sym
))
159 for (lsym
= *(lsymp
= &SCM_VELTS (scm_weak_symhash
)[hash
]);
161 lsym
= *(lsymp
= SCM_CDRLOC (lsym
)))
164 if (SCM_EQ_P (SCM_CAR (z
), sym
))
166 if (SCM_NFALSEP (definep
))
168 /* Move handle from scm_weak_symhash to scm_symhash. */
169 *lsymp
= SCM_CDR (lsym
);
170 SCM_SETCDR (lsym
, SCM_VELTS(scm_symhash
)[hash
]);
171 SCM_VELTS(scm_symhash
)[hash
] = lsym
;
178 return scm_wta (sym
, "uninterned symbol? ", "");
183 * looks up the symbol in an arbitrary obarray.
187 scm_sym2ovcell_soft (SCM sym
, SCM obarray
)
191 = scm_string_hash (SCM_UCHARS (sym
), SCM_LENGTH (sym
)) % SCM_LENGTH (obarray
);
193 for (lsym
= SCM_VELTS (obarray
)[hash
];
195 lsym
= SCM_CDR (lsym
))
198 if (SCM_EQ_P (SCM_CAR (z
), sym
))
210 scm_sym2ovcell (SCM sym
, SCM obarray
)
213 answer
= scm_sym2ovcell_soft (sym
, obarray
);
214 if (!SCM_FALSEP (answer
))
216 scm_wta (sym
, "uninterned symbol? ", "");
217 return SCM_UNSPECIFIED
; /* not reached */
220 /* Intern a symbol whose name is the LEN characters at NAME in OBARRAY.
222 OBARRAY should be a vector of lists, indexed by the name's hash
223 value, modulo OBARRAY's length. Each list has the form
224 ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the
225 value associated with that symbol (in the current module? in the
228 To "intern" a symbol means: if OBARRAY already contains a symbol by
229 that name, return its (SYMBOL . VALUE) pair; otherwise, create a
230 new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the
231 appropriate list of the OBARRAY, and return the pair.
233 If softness is non-zero, don't create a symbol if it isn't already
234 in OBARRAY; instead, just return #f.
236 If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and
237 return (SYMBOL . SCM_UNDEFINED).
239 If OBARRAY is scm_symhash, and that doesn't contain the symbol,
240 check scm_weak_symhash instead. */
244 scm_intern_obarray_soft (const char *name
,scm_sizet len
,SCM obarray
,unsigned int softness
)
246 scm_sizet raw_hash
= scm_string_hash ((unsigned char *) name
, len
);
252 if (SCM_FALSEP (obarray
))
254 hash
= raw_hash
% 1019;
255 goto uninterned_symbol
;
258 hash
= raw_hash
% SCM_LENGTH (obarray
);
261 for (lsym
= SCM_VELTS (obarray
)[hash
]; SCM_NIMP (lsym
); lsym
= SCM_CDR (lsym
))
264 SCM a
= SCM_CAR (lsym
);
266 unsigned char *tmp
= SCM_UCHARS (z
);
267 if (SCM_LENGTH (z
) != len
)
270 if (((unsigned char *) name
)[i
] != tmp
[i
])
279 if (SCM_EQ_P (obarray
, scm_symhash
))
281 obarray
= scm_weak_symhash
;
282 goto retry_new_obarray
;
293 SCM_SETCHARS (lsym
, duplicate_string (name
, len
));
294 SCM_SET_SYMBOL_HASH (lsym
, raw_hash
);
295 SCM_SET_PROP_SLOTS (lsym
, scm_cons (SCM_BOOL_F
, SCM_BOOL_F
));
296 SCM_SETLENGTH (lsym
, (long) len
, scm_tc7_symbol
);
298 SCM_SET_SYMBOL_PROPS (lsym
, SCM_EOL
);
299 if (SCM_FALSEP (obarray
))
303 SCM_NEWCELL (answer
);
305 SCM_SETCAR (answer
, lsym
);
306 SCM_SETCDR (answer
, SCM_UNDEFINED
);
317 SCM_SETCAR (a
, lsym
);
318 SCM_SETCDR (a
, SCM_UNDEFINED
);
320 SCM_SETCDR (b
, SCM_VELTS(obarray
)[hash
]);
321 SCM_VELTS(obarray
)[hash
] = b
;
329 scm_intern_obarray (const char *name
,scm_sizet len
,SCM obarray
)
331 return scm_intern_obarray_soft (name
, len
, obarray
, 0);
336 scm_intern (const char *name
,scm_sizet len
)
338 return scm_intern_obarray (name
, len
, scm_symhash
);
343 scm_intern0 (const char * name
)
345 return scm_intern (name
, strlen (name
));
349 /* Intern the symbol named NAME in scm_symhash, NAME is null-terminated. */
351 scm_sysintern0_no_module_lookup (const char *name
)
355 easy_answer
= scm_intern_obarray_soft (name
, strlen (name
), scm_symhash
, 1);
356 if (SCM_NIMP (easy_answer
))
364 scm_sizet len
= strlen (name
);
365 scm_sizet raw_hash
= scm_string_hash ((unsigned char *) name
, len
);
366 scm_sizet hash
= raw_hash
% scm_symhash_dim
;
369 SCM_SETCHARS (lsym
, name
);
370 SCM_SET_SYMBOL_HASH (lsym
, raw_hash
);
371 SCM_SET_PROP_SLOTS (lsym
, scm_cons (SCM_BOOL_F
, SCM_BOOL_F
));
372 SCM_SETLENGTH (lsym
, (long) len
, scm_tc7_symbol
);
374 lsym
= scm_cons (lsym
, SCM_UNDEFINED
);
375 SCM_VELTS (scm_symhash
)[hash
] = scm_cons (lsym
, SCM_VELTS (scm_symhash
)[hash
]);
381 /* Intern the symbol named NAME in scm_symhash, and give it the value
382 VAL. NAME is null-terminated. Use the current top_level lookup
383 closure to give NAME its value.
386 scm_sysintern (const char *name
, SCM val
)
388 SCM vcell
= scm_sysintern0 (name
);
389 SCM_SETCDR (vcell
, val
);
394 scm_sysintern0 (const char *name
)
397 if (scm_module_system_booted_p
398 && SCM_NIMP (lookup_proc
= SCM_TOP_LEVEL_LOOKUP_CLOSURE
))
400 SCM sym
= SCM_CAR (scm_intern0 (name
));
401 SCM vcell
= scm_sym2vcell (sym
, lookup_proc
, SCM_BOOL_T
);
402 if (SCM_FALSEP (vcell
))
403 scm_misc_error ("sysintern0", "can't define variable", sym
);
407 return scm_sysintern0_no_module_lookup (name
);
410 /* Lookup the value of the symbol named by the nul-terminated string
411 NAME in the current module. */
413 scm_symbol_value0 (const char *name
)
415 /* This looks silly - we look up the symbol twice. But it is in
416 fact necessary given the current module system because the module
417 lookup closures are written in scheme which needs real symbols. */
418 SCM symbol
= scm_intern_obarray_soft (name
, strlen (name
), scm_symhash
, 0);
419 SCM vcell
= scm_sym2vcell (SCM_CAR (symbol
),
420 SCM_TOP_LEVEL_LOOKUP_CLOSURE
,
422 if (SCM_FALSEP (vcell
))
423 return SCM_UNDEFINED
;
424 return SCM_CDR (vcell
);
427 SCM_DEFINE (scm_symbol_p
, "symbol?", 1, 0, 0,
429 "Returns @t{#t} if @var{obj} is a symbol, otherwise returns @t{#f}. (r5rs)")
430 #define FUNC_NAME s_scm_symbol_p
432 if SCM_IMP(obj
) return SCM_BOOL_F
;
433 return SCM_BOOL(SCM_SYMBOLP(obj
));
437 SCM_DEFINE (scm_symbol_to_string
, "symbol->string", 1, 0, 0,
439 "Returns the name of @var{symbol} as a string. If the symbol was part of\n"
440 "an object returned as the value of a literal expression (section\n"
441 "@pxref{Literal expressions,,,r4rs, The Revised^4 Report on Scheme}) or\n"
442 "by a call to the @samp{read} procedure, and its name contains alphabetic\n"
443 "characters, then the string returned will contain characters in the\n"
444 "implementation's preferred standard case---some implementations will\n"
445 "prefer upper case, others lower case. If the symbol was returned by\n"
446 "@samp{string->symbol}, the case of characters in the string returned\n"
447 "will be the same as the case in the string that was passed to\n"
448 "@samp{string->symbol}. It is an error to apply mutation procedures like\n"
449 "@code{string-set!} to strings returned by this procedure. (r5rs)\n\n"
450 "The following examples assume that the implementation's standard case is\n"
453 "@t{(symbol->string 'flying-fish) \n"
454 " ==> \"flying-fish\"\n"
455 "(symbol->string 'Martin) ==> \"martin\"\n"
457 " (string->symbol \"Malvina\")) \n"
461 #define FUNC_NAME s_scm_symbol_to_string
463 SCM_VALIDATE_SYMBOL (1, s
);
464 return scm_makfromstr (SCM_CHARS (s
), SCM_LENGTH (s
), 0);
469 SCM_DEFINE (scm_string_to_symbol
, "string->symbol", 1, 0, 0,
471 "Returns the symbol whose name is @var{string}. This procedure can\n"
472 "create symbols with names containing special characters or letters in\n"
473 "the non-standard case, but it is usually a bad idea to create such\n"
474 "symbols because in some implementations of Scheme they cannot be read as\n"
475 "themselves. See @samp{symbol->string}.\n\n"
476 "The following examples assume that the implementation's standard case is\n"
479 "@t{(eq? 'mISSISSIppi 'mississippi) \n"
481 "(string->symbol \"mISSISSIppi\") \n"
483 " @r{}the symbol with name \"mISSISSIppi\"\n"
484 "(eq? 'bitBlt (string->symbol \"bitBlt\")) \n"
488 " (symbol->string 'JollyWog))) \n"
490 "(string=? \"K. Harper, M.D.\"\n"
492 " (string->symbol \"K. Harper, M.D.\"))) \n"
496 #define FUNC_NAME s_scm_string_to_symbol
501 SCM_VALIDATE_ROSTRING (1,s
);
502 vcell
= scm_intern(SCM_ROCHARS(s
), (scm_sizet
)SCM_LENGTH(s
));
503 answer
= SCM_CAR (vcell
);
509 SCM_DEFINE (scm_string_to_obarray_symbol
, "string->obarray-symbol", 2, 1, 0,
510 (SCM o
, SCM s
, SCM softp
),
511 "Intern a new symbol in @var{obarray}, a symbol table, with name\n"
513 "If @var{obarray} is @code{#f}, use the default system symbol table. If\n"
514 "@var{obarray} is @code{#t}, the symbol should not be interned in any\n"
515 "symbol table; merely return the pair (@var{symbol}\n"
516 ". @var{#<undefined>}).\n\n"
517 "The @var{soft?} argument determines whether new symbol table entries\n"
518 "should be created when the specified symbol is not already present in\n"
519 "@var{obarray}. If @var{soft?} is specified and is a true value, then\n"
520 "new entries should not be added for symbols not already present in the\n"
521 "table; instead, simply return @code{#f}.")
522 #define FUNC_NAME s_scm_string_to_obarray_symbol
528 SCM_VALIDATE_ROSTRING (2,s
);
529 SCM_ASSERT (SCM_BOOLP (o
) || SCM_VECTORP (o
), o
, SCM_ARG1
, FUNC_NAME
);
531 softness
= (!SCM_UNBNDP (softp
) && !SCM_FALSEP(softp
));
532 /* iron out some screwy calling conventions */
535 else if (SCM_EQ_P (o
, SCM_BOOL_T
))
538 vcell
= scm_intern_obarray_soft (SCM_ROCHARS(s
),
539 (scm_sizet
)SCM_ROLENGTH(s
),
542 if (SCM_FALSEP (vcell
))
544 answer
= SCM_CAR (vcell
);
549 SCM_DEFINE (scm_intern_symbol
, "intern-symbol", 2, 0, 0,
551 "Add a new symbol to @var{obarray} with name @var{string}, bound to an\n"
552 "unspecified initial value. The symbol table is not modified if a symbol\n"
553 "with this name is already present.")
554 #define FUNC_NAME s_scm_intern_symbol
557 SCM_VALIDATE_SYMBOL (2,s
);
560 SCM_VALIDATE_VECTOR (1,o
);
561 hval
= scm_string_hash (SCM_UCHARS (s
), SCM_LENGTH (s
)) % SCM_LENGTH (o
);
562 /* If the symbol is already interned, simply return. */
567 for (lsym
= SCM_VELTS (o
)[hval
];
569 lsym
= SCM_CDR (lsym
))
571 sym
= SCM_CAR (lsym
);
572 if (SCM_EQ_P (SCM_CAR (sym
), s
))
575 return SCM_UNSPECIFIED
;
578 SCM_VELTS (o
)[hval
] =
579 scm_acons (s
, SCM_UNDEFINED
, SCM_VELTS (o
)[hval
]);
582 return SCM_UNSPECIFIED
;
586 SCM_DEFINE (scm_unintern_symbol
, "unintern-symbol", 2, 0, 0,
588 "Remove the symbol with name @var{string} from @var{obarray}. This\n"
589 "function returns @code{#t} if the symbol was present and @code{#f}\n"
591 #define FUNC_NAME s_scm_unintern_symbol
594 SCM_VALIDATE_SYMBOL (2,s
);
597 SCM_VALIDATE_VECTOR (1,o
);
598 hval
= scm_string_hash (SCM_UCHARS (s
), SCM_LENGTH (s
)) % SCM_LENGTH (o
);
604 for (lsym
= SCM_VELTS (o
)[hval
], lsym_follow
= SCM_BOOL_F
;
606 lsym_follow
= lsym
, lsym
= SCM_CDR (lsym
))
608 sym
= SCM_CAR (lsym
);
609 if (SCM_EQ_P (SCM_CAR (sym
), s
))
611 /* Found the symbol to unintern. */
612 if (SCM_FALSEP (lsym_follow
))
613 SCM_VELTS(o
)[hval
] = lsym
;
615 SCM_SETCDR (lsym_follow
, SCM_CDR(lsym
));
626 SCM_DEFINE (scm_symbol_binding
, "symbol-binding", 2, 0, 0,
628 "Look up in @var{obarray} the symbol whose name is @var{string}, and\n"
629 "return the value to which it is bound. If @var{obarray} is @code{#f},\n"
630 "use the global symbol table. If @var{string} is not interned in\n"
631 "@var{obarray}, an error is signalled.")
632 #define FUNC_NAME s_scm_symbol_binding
635 SCM_VALIDATE_SYMBOL (2,s
);
638 SCM_VALIDATE_VECTOR (1,o
);
639 vcell
= scm_sym2ovcell (s
, o
);
640 return SCM_CDR(vcell
);
645 SCM_DEFINE (scm_symbol_interned_p
, "symbol-interned?", 2, 0, 0,
647 "Return @var{#t} if @var{obarray} contains a symbol with name\n"
648 "@var{string}, and @var{#f} otherwise.")
649 #define FUNC_NAME s_scm_symbol_interned_p
652 SCM_VALIDATE_SYMBOL (2,s
);
655 SCM_VALIDATE_VECTOR (1,o
);
656 vcell
= scm_sym2ovcell_soft (s
, o
);
657 if (SCM_IMP (vcell
) && SCM_EQ_P (o
, scm_symhash
))
658 vcell
= scm_sym2ovcell_soft (s
, scm_weak_symhash
);
659 return (SCM_NIMP(vcell
)
666 SCM_DEFINE (scm_symbol_bound_p
, "symbol-bound?", 2, 0, 0,
668 "Return @var{#t} if @var{obarray} contains a symbol with name\n"
669 "@var{string} bound to a defined value. This differs from\n"
670 "@var{symbol-bound?} in that the mere mention of a symbol usually causes\n"
671 "it to be interned; @code{symbol-bound?} determines whether a symbol has\n"
672 "been given any meaningful value.")
673 #define FUNC_NAME s_scm_symbol_bound_p
676 SCM_VALIDATE_SYMBOL (2,s
);
679 SCM_VALIDATE_VECTOR (1,o
);
680 vcell
= scm_sym2ovcell_soft (s
, o
);
681 return SCM_BOOL (SCM_NIMP (vcell
) && !SCM_UNBNDP (SCM_CDR (vcell
)));
686 SCM_DEFINE (scm_symbol_set_x
, "symbol-set!", 3, 0, 0,
687 (SCM o
, SCM s
, SCM v
),
688 "Find the symbol in @var{obarray} whose name is @var{string}, and rebind\n"
689 "it to @var{value}. An error is signalled if @var{string} is not present\n"
691 #define FUNC_NAME s_scm_symbol_set_x
694 SCM_VALIDATE_SYMBOL (2,s
);
697 SCM_VALIDATE_VECTOR (1,o
);
698 vcell
= scm_sym2ovcell (s
, o
);
699 SCM_SETCDR (vcell
, v
);
700 return SCM_UNSPECIFIED
;
705 SCM_DEFINE (scm_symbol_fref
, "symbol-fref", 1, 0, 0,
707 "Return the contents of @var{symbol}'s @dfn{function slot}.")
708 #define FUNC_NAME s_scm_symbol_fref
710 SCM_VALIDATE_SYMBOL (1,s
);
711 return SCM_SYMBOL_FUNC (s
);
716 SCM_DEFINE (scm_symbol_pref
, "symbol-pref", 1, 0, 0,
718 "Return the @dfn{property list} currently associated with @var{symbol}.")
719 #define FUNC_NAME s_scm_symbol_pref
721 SCM_VALIDATE_SYMBOL (1,s
);
722 return SCM_SYMBOL_PROPS (s
);
727 SCM_DEFINE (scm_symbol_fset_x
, "symbol-fset!", 2, 0, 0,
729 "Change the binding of @var{symbol}'s function slot.")
730 #define FUNC_NAME s_scm_symbol_fset_x
732 SCM_VALIDATE_SYMBOL (1,s
);
733 SCM_SET_SYMBOL_FUNC (s
, val
);
734 return SCM_UNSPECIFIED
;
739 SCM_DEFINE (scm_symbol_pset_x
, "symbol-pset!", 2, 0, 0,
741 "Change the binding of @var{symbol}'s property slot.")
742 #define FUNC_NAME s_scm_symbol_pset_x
744 SCM_VALIDATE_SYMBOL (1,s
);
746 SCM_SET_SYMBOL_PROPS (s
, val
);
748 return SCM_UNSPECIFIED
;
753 SCM_DEFINE (scm_symbol_hash
, "symbol-hash", 1, 0, 0,
755 "Return a hash value for @var{symbol}.")
756 #define FUNC_NAME s_scm_symbol_hash
758 SCM_VALIDATE_SYMBOL (1, symbol
);
759 return SCM_MAKINUM (SCM_SYMBOL_HASH (symbol
));
765 copy_and_prune_obarray (SCM from
, SCM to
)
768 int length
= SCM_LENGTH (from
);
769 for (i
= 0; i
< length
; ++i
)
771 SCM head
= SCM_VELTS (from
)[i
]; /* GC protection */
775 while (SCM_NIMP (ls
))
777 if (!SCM_UNBNDP (SCM_CDAR (ls
)))
779 *lloc
= scm_cons (SCM_CAR (ls
), SCM_EOL
);
780 lloc
= SCM_CDRLOC (*lloc
);
784 SCM_VELTS (to
)[i
] = res
;
789 SCM_DEFINE (scm_builtin_bindings
, "builtin-bindings", 0, 0, 0,
791 "Create and return a copy of the global symbol table, removing all\n"
793 #define FUNC_NAME s_scm_builtin_bindings
795 int length
= SCM_LENGTH (scm_symhash
);
796 SCM obarray
= scm_make_vector (SCM_MAKINUM (length
), SCM_EOL
);
797 copy_and_prune_obarray (scm_symhash
, obarray
);
803 SCM_DEFINE (scm_builtin_weak_bindings
, "builtin-weak-bindings", 0, 0, 0,
806 #define FUNC_NAME s_scm_builtin_weak_bindings
808 int length
= SCM_LENGTH (scm_weak_symhash
);
809 SCM obarray
= scm_make_doubly_weak_hash_table (SCM_MAKINUM (length
));
810 copy_and_prune_obarray (scm_weak_symhash
, obarray
);
815 #define MAX_PREFIX_LENGTH 30
817 static int gensym_counter
;
819 SCM_DEFINE (scm_gensym
, "gensym", 0, 1, 0,
821 "Create a new symbol with name constructed from a prefix and a counter value.\n"
822 "The string PREFIX can be specified as an optional argument.\n"
823 "Default prefix is @code{g}. The counter is increased by 1 at each call.\n"
824 "There is no provision for resetting the counter.")
825 #define FUNC_NAME s_scm_gensym
827 char buf
[MAX_PREFIX_LENGTH
+ SCM_INTBUFLEN
];
830 if (SCM_UNBNDP (prefix
))
837 SCM_VALIDATE_STRINGORSUBSTR (1, prefix
);
838 len
= SCM_ROLENGTH (prefix
);
839 if (len
> MAX_PREFIX_LENGTH
)
840 name
= SCM_MUST_MALLOC (MAX_PREFIX_LENGTH
+ SCM_INTBUFLEN
);
841 strncpy (name
, SCM_ROCHARS (prefix
), len
);
844 int n_digits
= scm_iint2str (gensym_counter
++, 10, &name
[len
]);
845 SCM res
= SCM_CAR (scm_intern (name
, len
+ n_digits
));
847 scm_must_free (name
);
853 static int gentemp_counter
;
855 SCM_DEFINE (scm_gentemp
, "gentemp", 0, 2, 0,
856 (SCM prefix
, SCM obarray
),
857 "Create a new symbol with a name unique in an obarray.\n"
858 "The name is constructed from an optional string PREFIX and a counter\n"
859 "value. The default prefix is @var{t}. The OBARRAY is specified as a\n"
860 "second optional argument. Default is the system obarray where all\n"
861 "normal symbols are interned. The counter is increased by 1 at each\n"
862 "call. There is no provision for resetting the counter.")
863 #define FUNC_NAME s_scm_gentemp
865 char buf
[MAX_PREFIX_LENGTH
+ SCM_INTBUFLEN
];
868 if (SCM_UNBNDP (prefix
))
875 SCM_VALIDATE_STRINGORSUBSTR (1, prefix
);
876 len
= SCM_ROLENGTH (prefix
);
877 if (len
> MAX_PREFIX_LENGTH
)
878 name
= SCM_MUST_MALLOC (MAX_PREFIX_LENGTH
+ SCM_INTBUFLEN
);
879 strncpy (name
, SCM_ROCHARS (prefix
), len
);
882 if (SCM_UNBNDP (obarray
))
883 obarray
= scm_symhash
;
885 SCM_ASSERT ((SCM_VECTORP (obarray
) || SCM_WVECTP (obarray
)),
890 n_digits
= scm_iint2str (gentemp_counter
++, 10, &name
[len
]);
891 while (!SCM_FALSEP (scm_intern_obarray_soft (name
,
896 SCM vcell
= scm_intern_obarray_soft (name
,
901 scm_must_free (name
);
902 return SCM_CAR (vcell
);
912 #include "libguile/symbols.x"