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/variable.h"
52 #include "libguile/alist.h"
53 #include "libguile/root.h"
54 #include "libguile/strings.h"
55 #include "libguile/vectors.h"
56 #include "libguile/weaks.h"
58 #include "libguile/validate.h"
59 #include "libguile/symbols.h"
68 /* NUM_HASH_BUCKETS is the number of symbol scm_hash table buckets.
70 #define NUM_HASH_BUCKETS 137
80 scm_strhash (const unsigned char *str
, scm_sizet len
, unsigned long n
)
85 unsigned long h
= 264 % n
;
87 h
= ((h
<< 8) + ((unsigned) (scm_downcase (str
[h
% len
])))) % n
;
95 h
= ((h
<< 8) + ((unsigned) (scm_downcase (str
[--i
])))) % n
;
100 int scm_symhash_dim
= NUM_HASH_BUCKETS
;
104 * looks up the symbol in the symhash table.
108 scm_sym2vcell (SCM sym
, SCM thunk
, SCM definep
)
110 if (SCM_NIMP (thunk
))
114 if (SCM_TYP7 (thunk
) == scm_tc7_cclo
115 && SCM_TYP7 (SCM_CCLO_SUBR (thunk
)) == scm_tc7_subr_3
)
116 /* Bypass evaluator in the standard case. */
117 var
= SCM_SUBRF (SCM_CCLO_SUBR (thunk
)) (thunk
, sym
, definep
);
119 var
= scm_apply (thunk
, sym
, scm_cons (definep
, scm_listofnull
));
121 if (SCM_FALSEP (var
))
125 if (SCM_IMP(var
) || !SCM_VARIABLEP (var
))
126 scm_wta (sym
, "strangely interned symbol? ", "");
127 return SCM_VARVCELL (var
);
135 scm_sizet scm_hash
= scm_strhash (SCM_UCHARS (sym
), (scm_sizet
) SCM_LENGTH (sym
),
136 (unsigned long) scm_symhash_dim
);
139 for (lsym
= SCM_VELTS (scm_symhash
)[scm_hash
]; SCM_NIMP (lsym
); lsym
= SCM_CDR (lsym
))
142 if (SCM_EQ_P (SCM_CAR (z
), sym
))
149 for (lsym
= *(lsymp
= &SCM_VELTS (scm_weak_symhash
)[scm_hash
]);
151 lsym
= *(lsymp
= SCM_CDRLOC (lsym
)))
154 if (SCM_EQ_P (SCM_CAR (z
), sym
))
156 if (SCM_NFALSEP (definep
))
158 /* Move handle from scm_weak_symhash to scm_symhash. */
159 *lsymp
= SCM_CDR (lsym
);
160 SCM_SETCDR (lsym
, SCM_VELTS(scm_symhash
)[scm_hash
]);
161 SCM_VELTS(scm_symhash
)[scm_hash
] = lsym
;
168 return scm_wta (sym
, "uninterned symbol? ", "");
173 * looks up the symbol in an arbitrary obarray.
177 scm_sym2ovcell_soft (SCM sym
, SCM obarray
)
182 scm_hash
= scm_strhash (SCM_UCHARS (sym
),
183 (scm_sizet
) SCM_LENGTH (sym
),
184 SCM_LENGTH (obarray
));
186 for (lsym
= SCM_VELTS (obarray
)[scm_hash
];
188 lsym
= SCM_CDR (lsym
))
191 if (SCM_EQ_P (SCM_CAR (z
), sym
))
203 scm_sym2ovcell (SCM sym
, SCM obarray
)
206 answer
= scm_sym2ovcell_soft (sym
, obarray
);
207 if (!SCM_FALSEP (answer
))
209 scm_wta (sym
, "uninterned symbol? ", "");
210 return SCM_UNSPECIFIED
; /* not reached */
213 /* Intern a symbol whose name is the LEN characters at NAME in OBARRAY.
215 OBARRAY should be a vector of lists, indexed by the name's hash
216 value, modulo OBARRAY's length. Each list has the form
217 ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the
218 value associated with that symbol (in the current module? in the
221 To "intern" a symbol means: if OBARRAY already contains a symbol by
222 that name, return its (SYMBOL . VALUE) pair; otherwise, create a
223 new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the
224 appropriate list of the OBARRAY, and return the pair.
226 If softness is non-zero, don't create a symbol if it isn't already
227 in OBARRAY; instead, just return #f.
229 If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and
230 return (SYMBOL . SCM_UNDEFINED).
232 If OBARRAY is scm_symhash, and that doesn't contain the symbol,
233 check scm_weak_symhash instead. */
237 scm_intern_obarray_soft (const char *name
,scm_sizet len
,SCM obarray
,int softness
)
241 register scm_sizet i
;
242 register unsigned char *tmp
;
247 if (SCM_FALSEP (obarray
))
249 scm_hash
= scm_strhash (name
, len
, 1019);
250 goto uninterned_symbol
;
253 scm_hash
= scm_strhash (name
, len
, SCM_LENGTH (obarray
));
255 /* softness == -1 used to mean that it was known that the symbol
256 wasn't already in the obarray. I don't think there are any
257 callers that use that case any more, but just in case...
263 for (lsym
= SCM_VELTS (obarray
)[scm_hash
]; SCM_NIMP (lsym
); lsym
= SCM_CDR (lsym
))
267 tmp
= SCM_UCHARS (z
);
268 if (SCM_LENGTH (z
) != len
)
271 if (((unsigned char *) name
)[i
] != tmp
[i
])
282 if (SCM_EQ_P (obarray
, scm_symhash
))
284 obarray
= scm_weak_symhash
;
285 goto retry_new_obarray
;
295 lsym
= scm_makfromstr (name
, len
, SCM_SYMBOL_SLOTS
);
297 SCM_SETLENGTH (lsym
, (long) len
, scm_tc7_msymbol
);
298 SCM_SYMBOL_HASH (lsym
) = scm_hash
;
299 SCM_SET_SYMBOL_PROPS (lsym
, SCM_EOL
);
300 if (SCM_FALSEP (obarray
))
304 SCM_NEWCELL (answer
);
306 SCM_SETCAR (answer
, lsym
);
307 SCM_SETCDR (answer
, SCM_UNDEFINED
);
318 SCM_SETCAR (a
, lsym
);
319 SCM_SETCDR (a
, SCM_UNDEFINED
);
321 SCM_SETCDR (b
, SCM_VELTS(obarray
)[scm_hash
]);
322 SCM_VELTS(obarray
)[scm_hash
] = b
;
330 scm_intern_obarray (const char *name
,scm_sizet len
,SCM obarray
)
332 return scm_intern_obarray_soft (name
, len
, obarray
, 0);
337 scm_intern (const char *name
,scm_sizet len
)
339 return scm_intern_obarray (name
, len
, scm_symhash
);
344 scm_intern0 (const char * name
)
346 return scm_intern (name
, strlen (name
));
350 /* Intern the symbol named NAME in scm_symhash, NAME is null-terminated. */
352 scm_sysintern0_no_module_lookup (const char *name
)
356 easy_answer
= scm_intern_obarray_soft (name
, strlen (name
), scm_symhash
, 1);
357 if (SCM_NIMP (easy_answer
))
365 scm_sizet len
= strlen (name
);
366 scm_sizet scm_hash
= scm_strhash (name
, len
, (unsigned long) scm_symhash_dim
);
368 SCM_SETLENGTH (lsym
, (long) len
, scm_tc7_ssymbol
);
369 SCM_SETCHARS (lsym
, name
);
370 lsym
= scm_cons (lsym
, SCM_UNDEFINED
);
371 SCM_VELTS (scm_symhash
)[scm_hash
] = scm_cons (lsym
, SCM_VELTS (scm_symhash
)[scm_hash
]);
378 /* Is it safe to access SCM_TOP_LEVEL_LOOKUP_CLOSURE_VAR?
380 int scm_can_use_top_level_lookup_closure_var
;
382 /* Intern the symbol named NAME in scm_symhash, and give it the value
383 VAL. NAME is null-terminated. Use the current top_level lookup
384 closure to give NAME its value.
387 scm_sysintern (const char *name
, SCM val
)
389 SCM vcell
= scm_sysintern0 (name
);
390 SCM_SETCDR (vcell
, val
);
395 scm_sysintern0 (const char *name
)
398 if (scm_can_use_top_level_lookup_closure_var
&&
399 SCM_NIMP (lookup_proc
= SCM_CDR (scm_top_level_lookup_closure_var
)))
401 SCM sym
= SCM_CAR (scm_intern0 (name
));
402 SCM vcell
= scm_sym2vcell (sym
, lookup_proc
, SCM_BOOL_T
);
403 if (SCM_FALSEP (vcell
))
404 scm_misc_error ("sysintern0", "can't define variable", sym
);
408 return scm_sysintern0_no_module_lookup (name
);
411 /* Lookup the value of the symbol named by the nul-terminated string
412 NAME in the current module. */
414 scm_symbol_value0 (const char *name
)
416 /* This looks silly - we look up the symbol twice. But it is in
417 fact necessary given the current module system because the module
418 lookup closures are written in scheme which needs real symbols. */
419 SCM symbol
= scm_intern_obarray_soft (name
, strlen (name
), scm_symhash
, 0);
420 SCM vcell
= scm_sym2vcell (SCM_CAR (symbol
),
421 SCM_CDR (scm_top_level_lookup_closure_var
),
423 if (SCM_FALSEP (vcell
))
424 return SCM_UNDEFINED
;
425 return SCM_CDR (vcell
);
428 SCM_DEFINE (scm_symbol_p
, "symbol?", 1, 0, 0,
430 "Returns @t{#t} if @var{obj} is a symbol, otherwise returns @t{#f}. (r5rs)")
431 #define FUNC_NAME s_scm_symbol_p
433 if SCM_IMP(obj
) return SCM_BOOL_F
;
434 return SCM_BOOL(SCM_SYMBOLP(obj
));
438 SCM_DEFINE (scm_symbol_to_string
, "symbol->string", 1, 0, 0,
440 "Returns the name of @var{symbol} as a string. If the symbol was part of\n"
441 "an object returned as the value of a literal expression\n"
442 "(section @pxref{Literal expressions}) or by a call to the @samp{read} procedure,\n"
443 "and its name contains alphabetic characters, then the string returned\n"
444 "will contain characters in the implementation's preferred standard\n"
445 "case---some implementations will prefer upper case, others lower case.\n"
446 "If the symbol was returned by @samp{string->symbol}, the case of\n"
447 "characters in the string returned will be the same as the case in the\n"
448 "string that was passed to @samp{string->symbol}. It is an error\n"
449 "to apply mutation procedures like @code{string-set!} to strings returned\n"
450 "by this procedure. (r5rs)\n\n"
451 "The following examples assume that the implementation's standard case is\n"
454 "@t{(symbol->string 'flying-fish) \n"
455 " ==> \"flying-fish\"\n"
456 "(symbol->string 'Martin) ==> \"martin\"\n"
458 " (string->symbol "Malvina
")) \n"
462 #define FUNC_NAME s_scm_symbol_to_string
464 SCM_VALIDATE_SYMBOL (1,s
);
465 return scm_makfromstr(SCM_CHARS(s
), (scm_sizet
)SCM_LENGTH(s
), 0);
470 SCM_DEFINE (scm_string_to_symbol
, "string->symbol", 1, 0, 0,
472 "Returns the symbol whose name is @var{string}. This procedure can\n"
473 "create symbols with names containing special characters or letters in\n"
474 "the non-standard case, but it is usually a bad idea to create such\n"
475 "symbols because in some implementations of Scheme they cannot be read as\n"
476 "themselves. See @samp{symbol->string}.\n\n"
477 "The following examples assume that the implementation's standard case is\n"
480 "@t{(eq? 'mISSISSIppi 'mississippi) \n"
482 "(string->symbol \"mISSISSIppi\") \n"
484 " @r{}the symbol with name \"mISSISSIppi\"\n"
485 "(eq? 'bitBlt (string->symbol \"bitBlt\")) \n"
489 " (symbol->string 'JollyWog))) \n"
491 "(string=? \"K. Harper, M.D.\"\n"
493 " (string->symbol \"K. Harper, M.D.\"))) \n"
497 #define FUNC_NAME s_scm_string_to_symbol
502 SCM_VALIDATE_ROSTRING (1,s
);
503 vcell
= scm_intern(SCM_ROCHARS(s
), (scm_sizet
)SCM_LENGTH(s
));
504 answer
= SCM_CAR (vcell
);
510 SCM_DEFINE (scm_string_to_obarray_symbol
, "string->obarray-symbol", 2, 1, 0,
511 (SCM o
, SCM s
, SCM softp
),
512 "Intern a new symbol in @var{obarray}, a symbol table, with name\n"
514 "If @var{obarray} is @code{#f}, use the default system symbol table. If\n"
515 "@var{obarray} is @code{#t}, the symbol should not be interned in any\n"
516 "symbol table; merely return the pair (@var{symbol}\n"
517 ". @var{#<undefined>}).\n\n"
518 "The @var{soft?} argument determines whether new symbol table entries\n"
519 "should be created when the specified symbol is not already present in\n"
520 "@var{obarray}. If @var{soft?} is specified and is a true value, then\n"
521 "new entries should not be added for symbols not already present in the\n"
522 "table; instead, simply return @code{#f}.")
523 #define FUNC_NAME s_scm_string_to_obarray_symbol
529 SCM_VALIDATE_ROSTRING (2,s
);
530 SCM_ASSERT (SCM_BOOLP (o
) || SCM_VECTORP (o
), o
, SCM_ARG1
, FUNC_NAME
);
532 softness
= (!SCM_UNBNDP (softp
) && !SCM_FALSEP(softp
));
533 /* iron out some screwy calling conventions */
536 else if (SCM_TRUE_P (o
))
539 vcell
= scm_intern_obarray_soft (SCM_ROCHARS(s
),
540 (scm_sizet
)SCM_ROLENGTH(s
),
543 if (SCM_FALSEP (vcell
))
545 answer
= SCM_CAR (vcell
);
550 SCM_DEFINE (scm_intern_symbol
, "intern-symbol", 2, 0, 0,
552 "Add a new symbol to @var{obarray} with name @var{string}, bound to an\n"
553 "unspecified initial value. The symbol table is not modified if a symbol\n"
554 "with this name is already present.")
555 #define FUNC_NAME s_scm_intern_symbol
558 SCM_VALIDATE_SYMBOL (2,s
);
561 SCM_VALIDATE_VECTOR (1,o
);
562 hval
= scm_strhash (SCM_UCHARS (s
), SCM_LENGTH (s
), SCM_LENGTH(o
));
563 /* If the symbol is already interned, simply return. */
568 for (lsym
= SCM_VELTS (o
)[hval
];
570 lsym
= SCM_CDR (lsym
))
572 sym
= SCM_CAR (lsym
);
573 if (SCM_EQ_P (SCM_CAR (sym
), s
))
576 return SCM_UNSPECIFIED
;
579 SCM_VELTS (o
)[hval
] =
580 scm_acons (s
, SCM_UNDEFINED
, SCM_VELTS (o
)[hval
]);
583 return SCM_UNSPECIFIED
;
587 SCM_DEFINE (scm_unintern_symbol
, "unintern-symbol", 2, 0, 0,
589 "Remove the symbol with name @var{string} from @var{obarray}. This\n"
590 "function returns @code{#t} if the symbol was present and @code{#f}\n"
592 #define FUNC_NAME s_scm_unintern_symbol
595 SCM_VALIDATE_SYMBOL (2,s
);
598 SCM_VALIDATE_VECTOR (1,o
);
599 hval
= scm_strhash (SCM_UCHARS (s
), SCM_LENGTH (s
), SCM_LENGTH(o
));
605 for (lsym
= SCM_VELTS (o
)[hval
], lsym_follow
= SCM_BOOL_F
;
607 lsym_follow
= lsym
, lsym
= SCM_CDR (lsym
))
609 sym
= SCM_CAR (lsym
);
610 if (SCM_EQ_P (SCM_CAR (sym
), s
))
612 /* Found the symbol to unintern. */
613 if (SCM_FALSEP (lsym_follow
))
614 SCM_VELTS(o
)[hval
] = lsym
;
616 SCM_SETCDR (lsym_follow
, SCM_CDR(lsym
));
627 SCM_DEFINE (scm_symbol_binding
, "symbol-binding", 2, 0, 0,
629 "Look up in @var{obarray} the symbol whose name is @var{string}, and\n"
630 "return the value to which it is bound. If @var{obarray} is @code{#f},\n"
631 "use the global symbol table. If @var{string} is not interned in\n"
632 "@var{obarray}, an error is signalled.")
633 #define FUNC_NAME s_scm_symbol_binding
636 SCM_VALIDATE_SYMBOL (2,s
);
639 SCM_VALIDATE_VECTOR (1,o
);
640 vcell
= scm_sym2ovcell (s
, o
);
641 return SCM_CDR(vcell
);
646 SCM_DEFINE (scm_symbol_interned_p
, "symbol-interned?", 2, 0, 0,
648 "Return @var{#t} if @var{obarray} contains a symbol with name\n"
649 "@var{string}, and @var{#f} otherwise.")
650 #define FUNC_NAME s_scm_symbol_interned_p
653 SCM_VALIDATE_SYMBOL (2,s
);
656 SCM_VALIDATE_VECTOR (1,o
);
657 vcell
= scm_sym2ovcell_soft (s
, o
);
658 if (SCM_IMP (vcell
) && SCM_EQ_P (o
, scm_symhash
))
659 vcell
= scm_sym2ovcell_soft (s
, scm_weak_symhash
);
660 return (SCM_NIMP(vcell
)
667 SCM_DEFINE (scm_symbol_bound_p
, "symbol-bound?", 2, 0, 0,
669 "Return @var{#t} if @var{obarray} contains a symbol with name\n"
670 "@var{string} bound to a defined value. This differs from\n"
671 "@var{symbol-bound?} in that the mere mention of a symbol usually causes\n"
672 "it to be interned; @code{symbol-bound?} determines whether a symbol has\n"
673 "been given any meaningful value.")
674 #define FUNC_NAME s_scm_symbol_bound_p
677 SCM_VALIDATE_SYMBOL (2,s
);
680 SCM_VALIDATE_VECTOR (1,o
);
681 vcell
= scm_sym2ovcell_soft (s
, o
);
682 return SCM_BOOL (SCM_NIMP (vcell
) && !SCM_UNBNDP (SCM_CDR (vcell
)));
687 SCM_DEFINE (scm_symbol_set_x
, "symbol-set!", 3, 0, 0,
688 (SCM o
, SCM s
, SCM v
),
689 "Find the symbol in @var{obarray} whose name is @var{string}, and rebind\n"
690 "it to @var{value}. An error is signalled if @var{string} is not present\n"
692 #define FUNC_NAME s_scm_symbol_set_x
695 SCM_VALIDATE_SYMBOL (2,s
);
698 SCM_VALIDATE_VECTOR (1,o
);
699 vcell
= scm_sym2ovcell (s
, o
);
700 SCM_SETCDR (vcell
, v
);
701 return SCM_UNSPECIFIED
;
709 string
= scm_makfromstr (SCM_CHARS (s
), SCM_LENGTH (s
), SCM_SYMBOL_SLOTS
);
710 SCM_SETCHARS (s
, SCM_CHARS (string
));
711 SCM_SETLENGTH (s
, SCM_LENGTH (s
), scm_tc7_msymbol
);
712 SCM_SETCDR (string
, SCM_EOL
);
713 SCM_SETCAR (string
, SCM_EOL
);
714 SCM_SET_SYMBOL_PROPS (s
, SCM_EOL
);
715 /* If it's a tc7_ssymbol, it comes from scm_symhash */
716 SCM_SYMBOL_HASH (s
) = scm_strhash (SCM_UCHARS (s
),
717 (scm_sizet
) SCM_LENGTH (s
),
718 SCM_LENGTH (scm_symhash
));
722 SCM_DEFINE (scm_symbol_fref
, "symbol-fref", 1, 0, 0,
724 "Return the contents of @var{symbol}'s @dfn{function slot}.")
725 #define FUNC_NAME s_scm_symbol_fref
727 SCM_VALIDATE_SYMBOL (1,s
);
729 if (SCM_TYP7(s
) == scm_tc7_ssymbol
)
732 return SCM_SYMBOL_FUNC (s
);
737 SCM_DEFINE (scm_symbol_pref
, "symbol-pref", 1, 0, 0,
739 "Return the @dfn{property list} currently associated with @var{symbol}.")
740 #define FUNC_NAME s_scm_symbol_pref
742 SCM_VALIDATE_SYMBOL (1,s
);
744 if (SCM_TYP7(s
) == scm_tc7_ssymbol
)
747 return SCM_SYMBOL_PROPS (s
);
752 SCM_DEFINE (scm_symbol_fset_x
, "symbol-fset!", 2, 0, 0,
754 "Change the binding of @var{symbol}'s function slot.")
755 #define FUNC_NAME s_scm_symbol_fset_x
757 SCM_VALIDATE_SYMBOL (1,s
);
759 if (SCM_TYP7(s
) == scm_tc7_ssymbol
)
762 SCM_SET_SYMBOL_FUNC (s
, val
);
763 return SCM_UNSPECIFIED
;
768 SCM_DEFINE (scm_symbol_pset_x
, "symbol-pset!", 2, 0, 0,
770 "Change the binding of @var{symbol}'s property slot.")
771 #define FUNC_NAME s_scm_symbol_pset_x
773 SCM_VALIDATE_SYMBOL (1,s
);
775 if (SCM_TYP7(s
) == scm_tc7_ssymbol
)
777 SCM_SET_SYMBOL_PROPS (s
, val
);
779 return SCM_UNSPECIFIED
;
784 SCM_DEFINE (scm_symbol_hash
, "symbol-hash", 1, 0, 0,
786 "Return the hash value derived from @var{symbol}'s name, i.e. the integer\n"
787 "index into @var{symbol}'s obarray at which it is stored.")
788 #define FUNC_NAME s_scm_symbol_hash
790 SCM_VALIDATE_SYMBOL (1,s
);
791 if (SCM_TYP7(s
) == scm_tc7_ssymbol
)
793 return SCM_MAKINUM (SCM_UNPACK (s
) ^ SCM_SYMBOL_HASH (s
));
799 copy_and_prune_obarray (SCM from
, SCM to
)
802 int length
= SCM_LENGTH (from
);
803 for (i
= 0; i
< length
; ++i
)
805 SCM head
= SCM_VELTS (from
)[i
]; /* GC protection */
809 while (SCM_NIMP (ls
))
811 if (!SCM_UNBNDP (SCM_CDAR (ls
)))
813 *lloc
= scm_cons (SCM_CAR (ls
), SCM_EOL
);
814 lloc
= SCM_CDRLOC (*lloc
);
818 SCM_VELTS (to
)[i
] = res
;
823 SCM_DEFINE (scm_builtin_bindings
, "builtin-bindings", 0, 0, 0,
825 "Create and return a copy of the global symbol table, removing all\n"
827 #define FUNC_NAME s_scm_builtin_bindings
829 int length
= SCM_LENGTH (scm_symhash
);
830 SCM obarray
= scm_make_vector (SCM_MAKINUM (length
), SCM_EOL
);
831 copy_and_prune_obarray (scm_symhash
, obarray
);
837 SCM_DEFINE (scm_builtin_weak_bindings
, "builtin-weak-bindings", 0, 0, 0,
840 #define FUNC_NAME s_scm_builtin_weak_bindings
842 int length
= SCM_LENGTH (scm_weak_symhash
);
843 SCM obarray
= scm_make_doubly_weak_hash_table (SCM_MAKINUM (length
));
844 copy_and_prune_obarray (scm_weak_symhash
, obarray
);
849 static int gensym_counter
;
850 static SCM gensym_prefix
;
852 /* :FIXME:OPTIMIZE */
853 SCM_DEFINE (scm_gensym
, "gensym", 0, 2, 0,
854 (SCM name
, SCM obarray
),
855 "Create a new, unique symbol in @var{obarray}, using the global symbol\n"
856 "table by default. If @var{name} is specified, it should be used as a\n"
857 "prefix for the new symbol's name. The default prefix is @code{%%gensym}.")
858 #define FUNC_NAME s_scm_gensym
861 if (SCM_UNBNDP (name
))
862 name
= gensym_prefix
;
864 SCM_VALIDATE_ROSTRING (1,name
);
867 if (SCM_UNBNDP (obarray
))
869 obarray
= SCM_BOOL_F
;
873 SCM_ASSERT ((SCM_VECTORP (obarray
) || SCM_WVECTP (obarray
)),
877 while (!SCM_FALSEP (scm_string_to_obarray_symbol (obarray
, new, SCM_BOOL_T
)))
879 new = scm_string_append
881 scm_number_to_string (SCM_MAKINUM (gensym_counter
++),
884 return scm_string_to_obarray_symbol (obarray
, new, SCM_BOOL_F
);
892 gensym_prefix
= scm_permanent_object (scm_makfrom0str ("%%gensym"));
893 #include "libguile/symbols.x"