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 ((unsigned char *) name
, len
, 1019);
250 goto uninterned_symbol
;
253 scm_hash
= scm_strhash ((unsigned char *) 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 ((unsigned char *) name
,
368 (unsigned long) scm_symhash_dim
);
370 SCM_SETLENGTH (lsym
, (long) len
, scm_tc7_ssymbol
);
371 SCM_SETCHARS (lsym
, name
);
372 lsym
= scm_cons (lsym
, SCM_UNDEFINED
);
373 SCM_VELTS (scm_symhash
)[scm_hash
] = scm_cons (lsym
, SCM_VELTS (scm_symhash
)[scm_hash
]);
380 /* Is it safe to access SCM_TOP_LEVEL_LOOKUP_CLOSURE_VAR?
382 int scm_can_use_top_level_lookup_closure_var
;
384 /* Intern the symbol named NAME in scm_symhash, and give it the value
385 VAL. NAME is null-terminated. Use the current top_level lookup
386 closure to give NAME its value.
389 scm_sysintern (const char *name
, SCM val
)
391 SCM vcell
= scm_sysintern0 (name
);
392 SCM_SETCDR (vcell
, val
);
397 scm_sysintern0 (const char *name
)
400 if (scm_can_use_top_level_lookup_closure_var
&&
401 SCM_NIMP (lookup_proc
= SCM_CDR (scm_top_level_lookup_closure_var
)))
403 SCM sym
= SCM_CAR (scm_intern0 (name
));
404 SCM vcell
= scm_sym2vcell (sym
, lookup_proc
, SCM_BOOL_T
);
405 if (SCM_FALSEP (vcell
))
406 scm_misc_error ("sysintern0", "can't define variable", sym
);
410 return scm_sysintern0_no_module_lookup (name
);
413 /* Lookup the value of the symbol named by the nul-terminated string
414 NAME in the current module. */
416 scm_symbol_value0 (const char *name
)
418 /* This looks silly - we look up the symbol twice. But it is in
419 fact necessary given the current module system because the module
420 lookup closures are written in scheme which needs real symbols. */
421 SCM symbol
= scm_intern_obarray_soft (name
, strlen (name
), scm_symhash
, 0);
422 SCM vcell
= scm_sym2vcell (SCM_CAR (symbol
),
423 SCM_CDR (scm_top_level_lookup_closure_var
),
425 if (SCM_FALSEP (vcell
))
426 return SCM_UNDEFINED
;
427 return SCM_CDR (vcell
);
430 SCM_DEFINE (scm_symbol_p
, "symbol?", 1, 0, 0,
432 "Returns @t{#t} if @var{obj} is a symbol, otherwise returns @t{#f}. (r5rs)")
433 #define FUNC_NAME s_scm_symbol_p
435 if SCM_IMP(obj
) return SCM_BOOL_F
;
436 return SCM_BOOL(SCM_SYMBOLP(obj
));
440 SCM_DEFINE (scm_symbol_to_string
, "symbol->string", 1, 0, 0,
442 "Returns the name of @var{symbol} as a string. If the symbol was part of\n"
443 "an object returned as the value of a literal expression\n"
444 "(section @pxref{Literal expressions}) or by a call to the @samp{read} procedure,\n"
445 "and its name contains alphabetic characters, then the string returned\n"
446 "will contain characters in the implementation's preferred standard\n"
447 "case---some implementations will prefer upper case, others lower case.\n"
448 "If the symbol was returned by @samp{string->symbol}, the case of\n"
449 "characters in the string returned will be the same as the case in the\n"
450 "string that was passed to @samp{string->symbol}. It is an error\n"
451 "to apply mutation procedures like @code{string-set!} to strings returned\n"
452 "by this procedure. (r5rs)\n\n"
453 "The following examples assume that the implementation's standard case is\n"
456 "@t{(symbol->string 'flying-fish) \n"
457 " ==> \"flying-fish\"\n"
458 "(symbol->string 'Martin) ==> \"martin\"\n"
460 " (string->symbol "Malvina
")) \n"
464 #define FUNC_NAME s_scm_symbol_to_string
466 SCM_VALIDATE_SYMBOL (1,s
);
467 return scm_makfromstr(SCM_CHARS(s
), (scm_sizet
)SCM_LENGTH(s
), 0);
472 SCM_DEFINE (scm_string_to_symbol
, "string->symbol", 1, 0, 0,
474 "Returns the symbol whose name is @var{string}. This procedure can\n"
475 "create symbols with names containing special characters or letters in\n"
476 "the non-standard case, but it is usually a bad idea to create such\n"
477 "symbols because in some implementations of Scheme they cannot be read as\n"
478 "themselves. See @samp{symbol->string}.\n\n"
479 "The following examples assume that the implementation's standard case is\n"
482 "@t{(eq? 'mISSISSIppi 'mississippi) \n"
484 "(string->symbol \"mISSISSIppi\") \n"
486 " @r{}the symbol with name \"mISSISSIppi\"\n"
487 "(eq? 'bitBlt (string->symbol \"bitBlt\")) \n"
491 " (symbol->string 'JollyWog))) \n"
493 "(string=? \"K. Harper, M.D.\"\n"
495 " (string->symbol \"K. Harper, M.D.\"))) \n"
499 #define FUNC_NAME s_scm_string_to_symbol
504 SCM_VALIDATE_ROSTRING (1,s
);
505 vcell
= scm_intern(SCM_ROCHARS(s
), (scm_sizet
)SCM_LENGTH(s
));
506 answer
= SCM_CAR (vcell
);
512 SCM_DEFINE (scm_string_to_obarray_symbol
, "string->obarray-symbol", 2, 1, 0,
513 (SCM o
, SCM s
, SCM softp
),
514 "Intern a new symbol in @var{obarray}, a symbol table, with name\n"
516 "If @var{obarray} is @code{#f}, use the default system symbol table. If\n"
517 "@var{obarray} is @code{#t}, the symbol should not be interned in any\n"
518 "symbol table; merely return the pair (@var{symbol}\n"
519 ". @var{#<undefined>}).\n\n"
520 "The @var{soft?} argument determines whether new symbol table entries\n"
521 "should be created when the specified symbol is not already present in\n"
522 "@var{obarray}. If @var{soft?} is specified and is a true value, then\n"
523 "new entries should not be added for symbols not already present in the\n"
524 "table; instead, simply return @code{#f}.")
525 #define FUNC_NAME s_scm_string_to_obarray_symbol
531 SCM_VALIDATE_ROSTRING (2,s
);
532 SCM_ASSERT (SCM_BOOLP (o
) || SCM_VECTORP (o
), o
, SCM_ARG1
, FUNC_NAME
);
534 softness
= (!SCM_UNBNDP (softp
) && !SCM_FALSEP(softp
));
535 /* iron out some screwy calling conventions */
538 else if (SCM_EQ_P (o
, SCM_BOOL_T
))
541 vcell
= scm_intern_obarray_soft (SCM_ROCHARS(s
),
542 (scm_sizet
)SCM_ROLENGTH(s
),
545 if (SCM_FALSEP (vcell
))
547 answer
= SCM_CAR (vcell
);
552 SCM_DEFINE (scm_intern_symbol
, "intern-symbol", 2, 0, 0,
554 "Add a new symbol to @var{obarray} with name @var{string}, bound to an\n"
555 "unspecified initial value. The symbol table is not modified if a symbol\n"
556 "with this name is already present.")
557 #define FUNC_NAME s_scm_intern_symbol
560 SCM_VALIDATE_SYMBOL (2,s
);
563 SCM_VALIDATE_VECTOR (1,o
);
564 hval
= scm_strhash (SCM_UCHARS (s
), SCM_LENGTH (s
), SCM_LENGTH(o
));
565 /* If the symbol is already interned, simply return. */
570 for (lsym
= SCM_VELTS (o
)[hval
];
572 lsym
= SCM_CDR (lsym
))
574 sym
= SCM_CAR (lsym
);
575 if (SCM_EQ_P (SCM_CAR (sym
), s
))
578 return SCM_UNSPECIFIED
;
581 SCM_VELTS (o
)[hval
] =
582 scm_acons (s
, SCM_UNDEFINED
, SCM_VELTS (o
)[hval
]);
585 return SCM_UNSPECIFIED
;
589 SCM_DEFINE (scm_unintern_symbol
, "unintern-symbol", 2, 0, 0,
591 "Remove the symbol with name @var{string} from @var{obarray}. This\n"
592 "function returns @code{#t} if the symbol was present and @code{#f}\n"
594 #define FUNC_NAME s_scm_unintern_symbol
597 SCM_VALIDATE_SYMBOL (2,s
);
600 SCM_VALIDATE_VECTOR (1,o
);
601 hval
= scm_strhash (SCM_UCHARS (s
), SCM_LENGTH (s
), SCM_LENGTH(o
));
607 for (lsym
= SCM_VELTS (o
)[hval
], lsym_follow
= SCM_BOOL_F
;
609 lsym_follow
= lsym
, lsym
= SCM_CDR (lsym
))
611 sym
= SCM_CAR (lsym
);
612 if (SCM_EQ_P (SCM_CAR (sym
), s
))
614 /* Found the symbol to unintern. */
615 if (SCM_FALSEP (lsym_follow
))
616 SCM_VELTS(o
)[hval
] = lsym
;
618 SCM_SETCDR (lsym_follow
, SCM_CDR(lsym
));
629 SCM_DEFINE (scm_symbol_binding
, "symbol-binding", 2, 0, 0,
631 "Look up in @var{obarray} the symbol whose name is @var{string}, and\n"
632 "return the value to which it is bound. If @var{obarray} is @code{#f},\n"
633 "use the global symbol table. If @var{string} is not interned in\n"
634 "@var{obarray}, an error is signalled.")
635 #define FUNC_NAME s_scm_symbol_binding
638 SCM_VALIDATE_SYMBOL (2,s
);
641 SCM_VALIDATE_VECTOR (1,o
);
642 vcell
= scm_sym2ovcell (s
, o
);
643 return SCM_CDR(vcell
);
648 SCM_DEFINE (scm_symbol_interned_p
, "symbol-interned?", 2, 0, 0,
650 "Return @var{#t} if @var{obarray} contains a symbol with name\n"
651 "@var{string}, and @var{#f} otherwise.")
652 #define FUNC_NAME s_scm_symbol_interned_p
655 SCM_VALIDATE_SYMBOL (2,s
);
658 SCM_VALIDATE_VECTOR (1,o
);
659 vcell
= scm_sym2ovcell_soft (s
, o
);
660 if (SCM_IMP (vcell
) && SCM_EQ_P (o
, scm_symhash
))
661 vcell
= scm_sym2ovcell_soft (s
, scm_weak_symhash
);
662 return (SCM_NIMP(vcell
)
669 SCM_DEFINE (scm_symbol_bound_p
, "symbol-bound?", 2, 0, 0,
671 "Return @var{#t} if @var{obarray} contains a symbol with name\n"
672 "@var{string} bound to a defined value. This differs from\n"
673 "@var{symbol-bound?} in that the mere mention of a symbol usually causes\n"
674 "it to be interned; @code{symbol-bound?} determines whether a symbol has\n"
675 "been given any meaningful value.")
676 #define FUNC_NAME s_scm_symbol_bound_p
679 SCM_VALIDATE_SYMBOL (2,s
);
682 SCM_VALIDATE_VECTOR (1,o
);
683 vcell
= scm_sym2ovcell_soft (s
, o
);
684 return SCM_BOOL (SCM_NIMP (vcell
) && !SCM_UNBNDP (SCM_CDR (vcell
)));
689 SCM_DEFINE (scm_symbol_set_x
, "symbol-set!", 3, 0, 0,
690 (SCM o
, SCM s
, SCM v
),
691 "Find the symbol in @var{obarray} whose name is @var{string}, and rebind\n"
692 "it to @var{value}. An error is signalled if @var{string} is not present\n"
694 #define FUNC_NAME s_scm_symbol_set_x
697 SCM_VALIDATE_SYMBOL (2,s
);
700 SCM_VALIDATE_VECTOR (1,o
);
701 vcell
= scm_sym2ovcell (s
, o
);
702 SCM_SETCDR (vcell
, v
);
703 return SCM_UNSPECIFIED
;
711 string
= scm_makfromstr (SCM_CHARS (s
), SCM_LENGTH (s
), SCM_SYMBOL_SLOTS
);
712 SCM_SETCHARS (s
, SCM_CHARS (string
));
713 SCM_SETLENGTH (s
, SCM_LENGTH (s
), scm_tc7_msymbol
);
714 SCM_SETCDR (string
, SCM_EOL
);
715 SCM_SETCAR (string
, SCM_EOL
);
716 SCM_SET_SYMBOL_PROPS (s
, SCM_EOL
);
717 /* If it's a tc7_ssymbol, it comes from scm_symhash */
718 SCM_SYMBOL_HASH (s
) = scm_strhash (SCM_UCHARS (s
),
719 (scm_sizet
) SCM_LENGTH (s
),
720 SCM_LENGTH (scm_symhash
));
724 SCM_DEFINE (scm_symbol_fref
, "symbol-fref", 1, 0, 0,
726 "Return the contents of @var{symbol}'s @dfn{function slot}.")
727 #define FUNC_NAME s_scm_symbol_fref
729 SCM_VALIDATE_SYMBOL (1,s
);
731 if (SCM_TYP7(s
) == scm_tc7_ssymbol
)
734 return SCM_SYMBOL_FUNC (s
);
739 SCM_DEFINE (scm_symbol_pref
, "symbol-pref", 1, 0, 0,
741 "Return the @dfn{property list} currently associated with @var{symbol}.")
742 #define FUNC_NAME s_scm_symbol_pref
744 SCM_VALIDATE_SYMBOL (1,s
);
746 if (SCM_TYP7(s
) == scm_tc7_ssymbol
)
749 return SCM_SYMBOL_PROPS (s
);
754 SCM_DEFINE (scm_symbol_fset_x
, "symbol-fset!", 2, 0, 0,
756 "Change the binding of @var{symbol}'s function slot.")
757 #define FUNC_NAME s_scm_symbol_fset_x
759 SCM_VALIDATE_SYMBOL (1,s
);
761 if (SCM_TYP7(s
) == scm_tc7_ssymbol
)
764 SCM_SET_SYMBOL_FUNC (s
, val
);
765 return SCM_UNSPECIFIED
;
770 SCM_DEFINE (scm_symbol_pset_x
, "symbol-pset!", 2, 0, 0,
772 "Change the binding of @var{symbol}'s property slot.")
773 #define FUNC_NAME s_scm_symbol_pset_x
775 SCM_VALIDATE_SYMBOL (1,s
);
777 if (SCM_TYP7(s
) == scm_tc7_ssymbol
)
779 SCM_SET_SYMBOL_PROPS (s
, val
);
781 return SCM_UNSPECIFIED
;
786 SCM_DEFINE (scm_symbol_hash
, "symbol-hash", 1, 0, 0,
788 "Return the hash value derived from @var{symbol}'s name, i.e. the integer\n"
789 "index into @var{symbol}'s obarray at which it is stored.")
790 #define FUNC_NAME s_scm_symbol_hash
792 SCM_VALIDATE_SYMBOL (1,s
);
793 if (SCM_TYP7(s
) == scm_tc7_ssymbol
)
795 return SCM_MAKINUM (SCM_UNPACK (s
) ^ SCM_SYMBOL_HASH (s
));
801 copy_and_prune_obarray (SCM from
, SCM to
)
804 int length
= SCM_LENGTH (from
);
805 for (i
= 0; i
< length
; ++i
)
807 SCM head
= SCM_VELTS (from
)[i
]; /* GC protection */
811 while (SCM_NIMP (ls
))
813 if (!SCM_UNBNDP (SCM_CDAR (ls
)))
815 *lloc
= scm_cons (SCM_CAR (ls
), SCM_EOL
);
816 lloc
= SCM_CDRLOC (*lloc
);
820 SCM_VELTS (to
)[i
] = res
;
825 SCM_DEFINE (scm_builtin_bindings
, "builtin-bindings", 0, 0, 0,
827 "Create and return a copy of the global symbol table, removing all\n"
829 #define FUNC_NAME s_scm_builtin_bindings
831 int length
= SCM_LENGTH (scm_symhash
);
832 SCM obarray
= scm_make_vector (SCM_MAKINUM (length
), SCM_EOL
);
833 copy_and_prune_obarray (scm_symhash
, obarray
);
839 SCM_DEFINE (scm_builtin_weak_bindings
, "builtin-weak-bindings", 0, 0, 0,
842 #define FUNC_NAME s_scm_builtin_weak_bindings
844 int length
= SCM_LENGTH (scm_weak_symhash
);
845 SCM obarray
= scm_make_doubly_weak_hash_table (SCM_MAKINUM (length
));
846 copy_and_prune_obarray (scm_weak_symhash
, obarray
);
851 static int gensym_counter
;
852 static SCM gensym_prefix
;
854 /* :FIXME:OPTIMIZE */
855 SCM_DEFINE (scm_gensym
, "gensym", 0, 2, 0,
856 (SCM name
, SCM obarray
),
857 "Create a new, unique symbol in @var{obarray}, using the global symbol\n"
858 "table by default. If @var{name} is specified, it should be used as a\n"
859 "prefix for the new symbol's name. The default prefix is @code{%%gensym}.")
860 #define FUNC_NAME s_scm_gensym
863 if (SCM_UNBNDP (name
))
864 name
= gensym_prefix
;
866 SCM_VALIDATE_ROSTRING (1,name
);
869 if (SCM_UNBNDP (obarray
))
871 obarray
= SCM_BOOL_F
;
875 SCM_ASSERT ((SCM_VECTORP (obarray
) || SCM_WVECTP (obarray
)),
879 while (!SCM_FALSEP (scm_string_to_obarray_symbol (obarray
, new, SCM_BOOL_T
)))
881 new = scm_string_append
883 scm_number_to_string (SCM_MAKINUM (gensym_counter
++),
886 return scm_string_to_obarray_symbol (obarray
, new, SCM_BOOL_F
);
894 gensym_prefix
= scm_permanent_object (scm_makfrom0str ("%%gensym"));
895 #include "libguile/symbols.x"