1 /* This file contains definitions for deprecated features. When you
2 deprecate something, move it here when that is feasible.
5 /* Copyright (C) 2003 Free Software Foundation, Inc.
7 * This library is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU Lesser General Public
9 * License as published by the Free Software Foundation; either
10 * version 2.1 of the License, or (at your option) any later version.
12 * This library is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 * Lesser General Public License for more details.
17 * You should have received a copy of the GNU Lesser General Public
18 * License along with this library; if not, write to the Free Software
19 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
22 #include "libguile/_scm.h"
23 #include "libguile/deprecated.h"
24 #include "libguile/deprecation.h"
25 #include "libguile/snarf.h"
26 #include "libguile/validate.h"
27 #include "libguile/strings.h"
28 #include "libguile/strop.h"
29 #include "libguile/modules.h"
30 #include "libguile/eval.h"
31 #include "libguile/smob.h"
32 #include "libguile/procprop.h"
33 #include "libguile/vectors.h"
34 #include "libguile/hashtab.h"
35 #include "libguile/struct.h"
36 #include "libguile/variable.h"
37 #include "libguile/fluids.h"
38 #include "libguile/ports.h"
39 #include "libguile/eq.h"
40 #include "libguile/read.h"
41 #include "libguile/strports.h"
42 #include "libguile/smob.h"
43 #include "libguile/alist.h"
48 #if (SCM_ENABLE_DEPRECATED == 1)
50 /* From eval.c: Error messages of the evaluator. These were deprecated in
51 * guile 1.7.0 on 2003-06-02. */
52 const char scm_s_expression
[] = "missing or extra expression";
53 const char scm_s_test
[] = "bad test";
54 const char scm_s_body
[] = "bad body";
55 const char scm_s_bindings
[] = "bad bindings";
56 const char scm_s_variable
[] = "bad variable";
57 const char scm_s_clauses
[] = "bad or missing clauses";
58 const char scm_s_formals
[] = "bad formals";
61 SCM_REGISTER_PROC(s_substring_move_left_x
, "substring-move-left!", 5, 0, 0, scm_substring_move_x
);
63 SCM_REGISTER_PROC(s_substring_move_right_x
, "substring-move-right!", 5, 0, 0, scm_substring_move_x
);
66 scm_wta (SCM arg
, const char *pos
, const char *s_subr
)
68 if (!s_subr
|| !*s_subr
)
70 if ((~0x1fL
) & (long) pos
)
72 /* error string supplied. */
73 scm_misc_error (s_subr
, pos
, scm_list_1 (arg
));
77 /* numerical error code. */
78 scm_t_bits error
= (scm_t_bits
) pos
;
83 scm_wrong_type_arg (s_subr
, 0, arg
);
85 scm_wrong_type_arg (s_subr
, 1, arg
);
87 scm_wrong_type_arg (s_subr
, 2, arg
);
89 scm_wrong_type_arg (s_subr
, 3, arg
);
91 scm_wrong_type_arg (s_subr
, 4, arg
);
93 scm_wrong_type_arg (s_subr
, 5, arg
);
95 scm_wrong_type_arg (s_subr
, 6, arg
);
97 scm_wrong_type_arg (s_subr
, 7, arg
);
99 scm_wrong_num_args (arg
);
101 scm_out_of_range (s_subr
, arg
);
103 scm_memory_error (s_subr
);
105 /* this shouldn't happen. */
106 scm_misc_error (s_subr
, "Unknown error", SCM_EOL
);
109 return SCM_UNSPECIFIED
;
115 /* We can't use SCM objects here. One should be able to call
116 SCM_REGISTER_MODULE from a C++ constructor for a static
117 object. This happens before main and thus before libguile is
121 struct moddata
*link
;
126 static struct moddata
*registered_mods
= NULL
;
129 scm_register_module_xxx (char *module_name
, void *init_func
)
133 scm_c_issue_deprecation_warning
134 ("`scm_register_module_xxx' is deprecated. Use extensions instead.");
136 /* XXX - should we (and can we) DEFER_INTS here? */
138 for (md
= registered_mods
; md
; md
= md
->link
)
139 if (!strcmp (md
->module_name
, module_name
))
141 md
->init_func
= init_func
;
145 md
= (struct moddata
*) malloc (sizeof (struct moddata
));
149 "guile: can't register module (%s): not enough memory",
154 md
->module_name
= module_name
;
155 md
->init_func
= init_func
;
156 md
->link
= registered_mods
;
157 registered_mods
= md
;
160 SCM_DEFINE (scm_registered_modules
, "c-registered-modules", 0, 0, 0,
162 "Return a list of the object code modules that have been imported into\n"
163 "the current Guile process. Each element of the list is a pair whose\n"
164 "car is the name of the module, and whose cdr is the function handle\n"
165 "for that module's initializer function. The name is the string that\n"
166 "has been passed to scm_register_module_xxx.")
167 #define FUNC_NAME s_scm_registered_modules
173 for (md
= registered_mods
; md
; md
= md
->link
)
174 res
= scm_cons (scm_cons (scm_makfrom0str (md
->module_name
),
175 scm_ulong2num ((unsigned long) md
->init_func
)),
181 SCM_DEFINE (scm_clear_registered_modules
, "c-clear-registered-modules", 0, 0, 0,
183 "Destroy the list of modules registered with the current Guile process.\n"
184 "The return value is unspecified. @strong{Warning:} this function does\n"
185 "not actually unlink or deallocate these modules, but only destroys the\n"
186 "records of which modules have been loaded. It should therefore be used\n"
187 "only by module bookkeeping operations.")
188 #define FUNC_NAME s_scm_clear_registered_modules
190 struct moddata
*md1
, *md2
;
194 for (md1
= registered_mods
; md1
; md1
= md2
)
199 registered_mods
= NULL
;
202 return SCM_UNSPECIFIED
;
207 scm_remember (SCM
*ptr
)
209 scm_c_issue_deprecation_warning ("`scm_remember' is deprecated. "
210 "Use the `scm_remember_upto_here*' family of functions instead.");
214 scm_protect_object (SCM obj
)
216 scm_c_issue_deprecation_warning ("`scm_protect_object' is deprecated. "
217 "Use `scm_gc_protect_object' instead.");
218 return scm_gc_protect_object (obj
);
222 scm_unprotect_object (SCM obj
)
224 scm_c_issue_deprecation_warning ("`scm_unprotect_object' is deprecated. "
225 "Use `scm_gc_unprotect_object' instead.");
226 return scm_gc_unprotect_object (obj
);
229 SCM_SYMBOL (scm_sym_app
, "app");
230 SCM_SYMBOL (scm_sym_modules
, "modules");
231 static SCM module_prefix
= SCM_BOOL_F
;
232 static SCM make_modules_in_var
;
233 static SCM beautify_user_module_x_var
;
234 static SCM try_module_autoload_var
;
239 #define PERM(x) scm_permanent_object(x)
241 if (module_prefix
== SCM_BOOL_F
)
243 module_prefix
= PERM (scm_list_2 (scm_sym_app
, scm_sym_modules
));
244 make_modules_in_var
= PERM (scm_c_lookup ("make-modules-in"));
245 beautify_user_module_x_var
=
246 PERM (scm_c_lookup ("beautify-user-module!"));
247 try_module_autoload_var
= PERM (scm_c_lookup ("try-module-autoload"));
252 scm_the_root_module ()
254 init_module_stuff ();
255 scm_c_issue_deprecation_warning ("`scm_the_root_module' is deprecated. "
256 "Use `scm_c_resolve_module (\"guile\")' "
259 return scm_c_resolve_module ("guile");
263 scm_module_full_name (SCM name
)
265 init_module_stuff ();
266 if (SCM_EQ_P (SCM_CAR (name
), scm_sym_app
))
269 return scm_append (scm_list_2 (module_prefix
, name
));
273 scm_make_module (SCM name
)
275 init_module_stuff ();
276 scm_c_issue_deprecation_warning ("`scm_make_module' is deprecated. "
277 "Use `scm_c_define_module instead.");
279 return scm_call_2 (SCM_VARIABLE_REF (make_modules_in_var
),
280 scm_the_root_module (),
281 scm_module_full_name (name
));
285 scm_ensure_user_module (SCM module
)
287 init_module_stuff ();
288 scm_c_issue_deprecation_warning ("`scm_ensure_user_module' is deprecated. "
289 "Use `scm_c_define_module instead.");
291 scm_call_1 (SCM_VARIABLE_REF (beautify_user_module_x_var
), module
);
292 return SCM_UNSPECIFIED
;
296 scm_load_scheme_module (SCM name
)
298 init_module_stuff ();
299 scm_c_issue_deprecation_warning ("`scm_load_scheme_module' is deprecated. "
300 "Use `scm_c_resolve_module instead.");
302 return scm_call_1 (SCM_VARIABLE_REF (try_module_autoload_var
), name
);
305 /* This is implemented in C solely for SCM_COERCE_OUTPORT ... */
308 maybe_close_port (void *data
, SCM port
)
310 SCM except
= (SCM
)data
;
312 while (!SCM_NULLP (except
))
314 SCM p
= SCM_COERCE_OUTPORT (SCM_CAR (except
));
315 if (SCM_EQ_P (p
, port
))
317 except
= SCM_CDR (except
);
320 scm_close_port (port
);
323 SCM_DEFINE (scm_close_all_ports_except
, "close-all-ports-except", 0, 0, 1,
325 "[DEPRECATED] Close all open file ports used by the interpreter\n"
326 "except for those supplied as arguments. This procedure\n"
327 "was intended to be used before an exec call to close file descriptors\n"
328 "which are not needed in the new process. However it has the\n"
329 "undesirable side effect of flushing buffers, so it's deprecated.\n"
330 "Use port-for-each instead.")
331 #define FUNC_NAME s_scm_close_all_ports_except
334 SCM_VALIDATE_REST_ARGUMENT (ports
);
336 for (p
= ports
; !SCM_NULLP (p
); p
= SCM_CDR (p
))
337 SCM_VALIDATE_OPPORT (SCM_ARG1
, SCM_COERCE_OUTPORT (SCM_CAR (p
)));
339 scm_c_port_for_each (maybe_close_port
, ports
);
341 return SCM_UNSPECIFIED
;
345 SCM_DEFINE (scm_variable_set_name_hint
, "variable-set-name-hint!", 2, 0, 0,
347 "Do not use this function.")
348 #define FUNC_NAME s_scm_variable_set_name_hint
350 SCM_VALIDATE_VARIABLE (1, var
);
351 SCM_VALIDATE_SYMBOL (2, hint
);
352 scm_c_issue_deprecation_warning
353 ("'variable-set-name-hint!' is deprecated. Do not use it.");
354 return SCM_UNSPECIFIED
;
358 SCM_DEFINE (scm_builtin_variable
, "builtin-variable", 1, 0, 0,
360 "Do not use this function.")
361 #define FUNC_NAME s_scm_builtin_variable
363 SCM_VALIDATE_SYMBOL (1,name
);
364 scm_c_issue_deprecation_warning ("`builtin-variable' is deprecated. "
365 "Use module system operations instead.");
366 return scm_sym2var (name
, SCM_BOOL_F
, SCM_BOOL_T
);
371 scm_makstr (size_t len
, int dummy
)
373 scm_c_issue_deprecation_warning
374 ("'scm_makstr' is deprecated. Use 'scm_allocate_string' instead.");
375 return scm_allocate_string (len
);
379 scm_makfromstr (const char *src
, size_t len
, int dummy SCM_UNUSED
)
381 scm_c_issue_deprecation_warning ("`scm_makfromstr' is deprecated. "
382 "Use `scm_mem2string' instead.");
384 return scm_mem2string (src
, len
);
388 scm_internal_with_fluids (SCM fluids
, SCM values
, SCM (*cproc
) (), void *cdata
)
390 scm_c_issue_deprecation_warning ("`scm_internal_with_fluids' is deprecated. "
391 "Use `scm_c_with_fluids' instead.");
393 return scm_c_with_fluids (fluids
, values
, cproc
, cdata
);
397 scm_make_gsubr (const char *name
, int req
, int opt
, int rst
, SCM (*fcn
)())
399 scm_c_issue_deprecation_warning
400 ("`scm_make_gsubr' is deprecated. Use `scm_c_define_gsubr' instead.");
402 return scm_c_define_gsubr (name
, req
, opt
, rst
, fcn
);
406 scm_make_gsubr_with_generic (const char *name
,
407 int req
, int opt
, int rst
,
408 SCM (*fcn
)(), SCM
*gf
)
410 scm_c_issue_deprecation_warning
411 ("`scm_make_gsubr_with_generic' is deprecated. "
412 "Use `scm_c_define_gsubr_with_generic' instead.");
414 return scm_c_define_gsubr_with_generic (name
, req
, opt
, rst
, fcn
, gf
);
418 scm_create_hook (const char *name
, int n_args
)
420 scm_c_issue_deprecation_warning
421 ("'scm_create_hook' is deprecated. "
422 "Use 'scm_make_hook' and 'scm_c_define' instead.");
424 SCM hook
= scm_make_hook (SCM_MAKINUM (n_args
));
425 scm_c_define (name
, hook
);
426 return scm_permanent_object (hook
);
430 SCM_DEFINE (scm_sloppy_memq
, "sloppy-memq", 2, 0, 0,
432 "This procedure behaves like @code{memq}, but does no type or error checking.\n"
433 "Its use is recommended only in writing Guile internals,\n"
434 "not for high-level Scheme programs.")
435 #define FUNC_NAME s_scm_sloppy_memq
437 scm_c_issue_deprecation_warning
438 ("'sloppy-memq' is deprecated. Use 'memq' instead.");
440 for(; SCM_CONSP (lst
); lst
= SCM_CDR(lst
))
442 if (SCM_EQ_P (SCM_CAR (lst
), x
))
450 SCM_DEFINE (scm_sloppy_memv
, "sloppy-memv", 2, 0, 0,
452 "This procedure behaves like @code{memv}, but does no type or error checking.\n"
453 "Its use is recommended only in writing Guile internals,\n"
454 "not for high-level Scheme programs.")
455 #define FUNC_NAME s_scm_sloppy_memv
457 scm_c_issue_deprecation_warning
458 ("'sloppy-memv' is deprecated. Use 'memv' instead.");
460 for(; SCM_CONSP (lst
); lst
= SCM_CDR(lst
))
462 if (! SCM_FALSEP (scm_eqv_p (SCM_CAR (lst
), x
)))
470 SCM_DEFINE (scm_sloppy_member
, "sloppy-member", 2, 0, 0,
472 "This procedure behaves like @code{member}, but does no type or error checking.\n"
473 "Its use is recommended only in writing Guile internals,\n"
474 "not for high-level Scheme programs.")
475 #define FUNC_NAME s_scm_sloppy_member
477 scm_c_issue_deprecation_warning
478 ("'sloppy-member' is deprecated. Use 'member' instead.");
480 for(; SCM_CONSP (lst
); lst
= SCM_CDR(lst
))
482 if (! SCM_FALSEP (scm_equal_p (SCM_CAR (lst
), x
)))
489 SCM_SYMBOL (scm_end_of_file_key
, "end-of-file");
491 SCM_DEFINE (scm_read_and_eval_x
, "read-and-eval!", 0, 1, 0,
493 "Read a form from @var{port} (standard input by default), and evaluate it\n"
494 "(memoizing it in the process) in the top-level environment. If no data\n"
495 "is left to be read from @var{port}, an @code{end-of-file} error is\n"
497 #define FUNC_NAME s_scm_read_and_eval_x
501 scm_c_issue_deprecation_warning
502 ("'read-and-eval!' is deprecated. Use 'read' and 'eval' instead.");
504 form
= scm_read (port
);
505 if (SCM_EOF_OBJECT_P (form
))
506 scm_ithrow (scm_end_of_file_key
, SCM_EOL
, 1);
507 return scm_eval_x (form
, scm_current_module ());
512 scm_make_subr_opt (const char *name
, int type
, SCM (*fcn
) (), int set
)
514 scm_c_issue_deprecation_warning
515 ("`scm_make_subr_opt' is deprecated. Use `scm_c_make_subr' or "
516 "`scm_c_define_subr' instead.");
519 return scm_c_define_subr (name
, type
, fcn
);
521 return scm_c_make_subr (name
, type
, fcn
);
525 scm_make_subr (const char *name
, int type
, SCM (*fcn
) ())
527 scm_c_issue_deprecation_warning
528 ("`scm_make_subr' is deprecated. Use `scm_c_define_subr' instead.");
530 return scm_c_define_subr (name
, type
, fcn
);
534 scm_make_subr_with_generic (const char *name
, int type
, SCM (*fcn
) (), SCM
*gf
)
536 scm_c_issue_deprecation_warning
537 ("`scm_make_subr_with_generic' is deprecated. Use "
538 "`scm_c_define_subr_with_generic' instead.");
540 return scm_c_define_subr_with_generic (name
, type
, fcn
, gf
);
543 /* Call thunk(closure) underneath a top-level error handler.
544 * If an error occurs, pass the exitval through err_filter and return it.
545 * If no error occurs, return the value of thunk.
549 typedef int setjmp_type
;
551 typedef long setjmp_type
;
554 struct cce_handler_data
{
555 SCM (*err_filter
) ();
560 invoke_err_filter (void *d
, SCM tag
, SCM args
)
562 struct cce_handler_data
*data
= (struct cce_handler_data
*)d
;
563 return data
->err_filter (SCM_BOOL_F
, data
->closure
);
567 scm_call_catching_errors (SCM (*thunk
)(), SCM (*err_filter
)(), void *closure
)
569 scm_c_issue_deprecation_warning
570 ("'scm_call_catching_errors' is deprecated. "
571 "Use 'scm_internal_catch' instead.");
574 struct cce_handler_data data
;
575 data
.err_filter
= err_filter
;
576 data
.closure
= closure
;
577 return scm_internal_catch (SCM_BOOL_T
,
578 (scm_t_catch_body
)thunk
, closure
,
579 (scm_t_catch_handler
)invoke_err_filter
, &data
);
584 scm_make_smob_type_mfpe (char *name
, size_t size
,
586 size_t (*free
) (SCM
),
587 int (*print
) (SCM
, SCM
, scm_print_state
*),
588 SCM (*equalp
) (SCM
, SCM
))
590 scm_c_issue_deprecation_warning
591 ("'scm_make_smob_type_mfpe' is deprecated. "
592 "Use 'scm_make_smob_type' plus 'scm_set_smob_*' instead.");
595 long answer
= scm_make_smob_type (name
, size
);
596 scm_set_smob_mfpe (answer
, mark
, free
, print
, equalp
);
602 scm_set_smob_mfpe (long tc
,
604 size_t (*free
) (SCM
),
605 int (*print
) (SCM
, SCM
, scm_print_state
*),
606 SCM (*equalp
) (SCM
, SCM
))
608 scm_c_issue_deprecation_warning
609 ("'scm_set_smob_mfpe' is deprecated. "
610 "Use 'scm_set_smob_mark' instead, for example.");
612 if (mark
) scm_set_smob_mark (tc
, mark
);
613 if (free
) scm_set_smob_free (tc
, free
);
614 if (print
) scm_set_smob_print (tc
, print
);
615 if (equalp
) scm_set_smob_equalp (tc
, equalp
);
619 scm_read_0str (char *expr
)
621 scm_c_issue_deprecation_warning
622 ("scm_read_0str is deprecated. Use scm_c_read_string instead.");
624 return scm_c_read_string (expr
);
628 scm_eval_0str (const char *expr
)
630 scm_c_issue_deprecation_warning
631 ("scm_eval_0str is deprecated. Use scm_c_eval_string instead.");
633 return scm_c_eval_string (expr
);
637 scm_strprint_obj (SCM obj
)
639 scm_c_issue_deprecation_warning
640 ("scm_strprint_obj is deprecated. Use scm_object_to_string instead.");
641 return scm_object_to_string (obj
, SCM_UNDEFINED
);
645 scm_i_object_chars (SCM obj
)
647 scm_c_issue_deprecation_warning
648 ("SCM_CHARS is deprecated. Use SCM_STRING_CHARS or "
649 "SCM_SYMBOL_CHARS instead.");
650 if (SCM_STRINGP (obj
))
651 return SCM_STRING_CHARS (obj
);
652 if (SCM_SYMBOLP (obj
))
653 return SCM_SYMBOL_CHARS (obj
);
658 scm_i_object_length (SCM obj
)
660 scm_c_issue_deprecation_warning
661 ("SCM_LENGTH is deprecated. Use SCM_STRING_LENGTH instead, for example.");
662 if (SCM_STRINGP (obj
))
663 return SCM_STRING_LENGTH (obj
);
664 if (SCM_SYMBOLP (obj
))
665 return SCM_SYMBOL_LENGTH (obj
);
666 if (SCM_VECTORP (obj
))
667 return SCM_VECTOR_LENGTH (obj
);
672 scm_sym2ovcell_soft (SCM sym
, SCM obarray
)
675 size_t hash
= SCM_SYMBOL_HASH (sym
) % SCM_VECTOR_LENGTH (obarray
);
677 scm_c_issue_deprecation_warning ("`scm_sym2ovcell_soft' is deprecated. "
678 "Use hashtables instead.");
681 for (lsym
= SCM_VECTOR_REF (obarray
, hash
);
683 lsym
= SCM_CDR (lsym
))
686 if (SCM_EQ_P (SCM_CAR (z
), sym
))
698 scm_sym2ovcell (SCM sym
, SCM obarray
)
699 #define FUNC_NAME "scm_sym2ovcell"
703 scm_c_issue_deprecation_warning ("`scm_sym2ovcell' is deprecated. "
704 "Use hashtables instead.");
706 answer
= scm_sym2ovcell_soft (sym
, obarray
);
707 if (!SCM_FALSEP (answer
))
709 SCM_MISC_ERROR ("uninterned symbol: ~S", scm_list_1 (sym
));
710 return SCM_UNSPECIFIED
; /* not reached */
715 /* Intern a symbol whose name is the LEN characters at NAME in OBARRAY.
717 OBARRAY should be a vector of lists, indexed by the name's hash
718 value, modulo OBARRAY's length. Each list has the form
719 ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the
720 value associated with that symbol (in the current module? in the
723 To "intern" a symbol means: if OBARRAY already contains a symbol by
724 that name, return its (SYMBOL . VALUE) pair; otherwise, create a
725 new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the
726 appropriate list of the OBARRAY, and return the pair.
728 If softness is non-zero, don't create a symbol if it isn't already
729 in OBARRAY; instead, just return #f.
731 If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and
732 return (SYMBOL . SCM_UNDEFINED). */
736 scm_intern_obarray_soft (const char *name
,size_t len
,SCM obarray
,unsigned int softness
)
738 SCM symbol
= scm_mem2symbol (name
, len
);
739 size_t raw_hash
= SCM_SYMBOL_HASH (symbol
);
743 scm_c_issue_deprecation_warning ("`scm_intern_obarray_soft' is deprecated. "
744 "Use hashtables instead.");
746 if (SCM_FALSEP (obarray
))
751 return scm_cons (symbol
, SCM_UNDEFINED
);
754 hash
= raw_hash
% SCM_VECTOR_LENGTH (obarray
);
756 for (lsym
= SCM_VECTOR_REF(obarray
, hash
);
757 SCM_NIMP (lsym
); lsym
= SCM_CDR (lsym
))
759 SCM a
= SCM_CAR (lsym
);
761 if (SCM_EQ_P (z
, symbol
))
771 SCM cell
= scm_cons (symbol
, SCM_UNDEFINED
);
772 SCM slot
= SCM_VECTOR_REF (obarray
, hash
);
774 SCM_VECTOR_SET (obarray
, hash
, scm_cons (cell
, slot
));
782 scm_intern_obarray (const char *name
,size_t len
,SCM obarray
)
784 scm_c_issue_deprecation_warning ("`scm_intern_obarray' is deprecated. "
785 "Use hashtables instead.");
787 return scm_intern_obarray_soft (name
, len
, obarray
, 0);
790 /* Lookup the value of the symbol named by the nul-terminated string
791 NAME in the current module. */
793 scm_symbol_value0 (const char *name
)
795 scm_c_issue_deprecation_warning ("`scm_symbol_value0' is deprecated. "
796 "Use `scm_lookup' instead.");
798 return scm_variable_ref (scm_c_lookup (name
));
801 SCM_DEFINE (scm_string_to_obarray_symbol
, "string->obarray-symbol", 2, 1, 0,
802 (SCM o
, SCM s
, SCM softp
),
803 "Intern a new symbol in @var{obarray}, a symbol table, with name\n"
805 "If @var{obarray} is @code{#f}, use the default system symbol table. If\n"
806 "@var{obarray} is @code{#t}, the symbol should not be interned in any\n"
807 "symbol table; merely return the pair (@var{symbol}\n"
808 ". @var{#<undefined>}).\n\n"
809 "The @var{soft?} argument determines whether new symbol table entries\n"
810 "should be created when the specified symbol is not already present in\n"
811 "@var{obarray}. If @var{soft?} is specified and is a true value, then\n"
812 "new entries should not be added for symbols not already present in the\n"
813 "table; instead, simply return @code{#f}.")
814 #define FUNC_NAME s_scm_string_to_obarray_symbol
820 SCM_VALIDATE_STRING (2, s
);
821 SCM_ASSERT (SCM_BOOLP (o
) || SCM_VECTORP (o
), o
, SCM_ARG1
, FUNC_NAME
);
823 scm_c_issue_deprecation_warning ("`string->obarray-symbol' is deprecated. "
824 "Use hashtables instead.");
826 softness
= (!SCM_UNBNDP (softp
) && !SCM_FALSEP(softp
));
827 /* iron out some screwy calling conventions */
830 /* nothing interesting to do here. */
831 return scm_string_to_symbol (s
);
833 else if (SCM_EQ_P (o
, SCM_BOOL_T
))
836 vcell
= scm_intern_obarray_soft (SCM_STRING_CHARS(s
),
837 SCM_STRING_LENGTH (s
),
840 if (SCM_FALSEP (vcell
))
842 answer
= SCM_CAR (vcell
);
847 SCM_DEFINE (scm_intern_symbol
, "intern-symbol", 2, 0, 0,
849 "Add a new symbol to @var{obarray} with name @var{string}, bound to an\n"
850 "unspecified initial value. The symbol table is not modified if a symbol\n"
851 "with this name is already present.")
852 #define FUNC_NAME s_scm_intern_symbol
855 SCM_VALIDATE_SYMBOL (2,s
);
857 return SCM_UNSPECIFIED
;
859 scm_c_issue_deprecation_warning ("`intern-symbol' is deprecated. "
860 "Use hashtables instead.");
862 SCM_VALIDATE_VECTOR (1,o
);
863 hval
= SCM_SYMBOL_HASH (s
) % SCM_VECTOR_LENGTH (o
);
864 /* If the symbol is already interned, simply return. */
869 for (lsym
= SCM_VECTOR_REF (o
, hval
);
871 lsym
= SCM_CDR (lsym
))
873 sym
= SCM_CAR (lsym
);
874 if (SCM_EQ_P (SCM_CAR (sym
), s
))
877 return SCM_UNSPECIFIED
;
880 SCM_VECTOR_SET (o
, hval
,
881 scm_acons (s
, SCM_UNDEFINED
,
882 SCM_VECTOR_REF (o
, hval
)));
885 return SCM_UNSPECIFIED
;
889 SCM_DEFINE (scm_unintern_symbol
, "unintern-symbol", 2, 0, 0,
891 "Remove the symbol with name @var{string} from @var{obarray}. This\n"
892 "function returns @code{#t} if the symbol was present and @code{#f}\n"
894 #define FUNC_NAME s_scm_unintern_symbol
898 scm_c_issue_deprecation_warning ("`unintern-symbol' is deprecated. "
899 "Use hashtables instead.");
901 SCM_VALIDATE_SYMBOL (2,s
);
904 SCM_VALIDATE_VECTOR (1,o
);
905 hval
= SCM_SYMBOL_HASH (s
) % SCM_VECTOR_LENGTH (o
);
911 for (lsym
= SCM_VECTOR_REF (o
, hval
), lsym_follow
= SCM_BOOL_F
;
913 lsym_follow
= lsym
, lsym
= SCM_CDR (lsym
))
915 sym
= SCM_CAR (lsym
);
916 if (SCM_EQ_P (SCM_CAR (sym
), s
))
918 /* Found the symbol to unintern. */
919 if (SCM_FALSEP (lsym_follow
))
920 SCM_VECTOR_SET (o
, hval
, lsym
);
922 SCM_SETCDR (lsym_follow
, SCM_CDR(lsym
));
933 SCM_DEFINE (scm_symbol_binding
, "symbol-binding", 2, 0, 0,
935 "Look up in @var{obarray} the symbol whose name is @var{string}, and\n"
936 "return the value to which it is bound. If @var{obarray} is @code{#f},\n"
937 "use the global symbol table. If @var{string} is not interned in\n"
938 "@var{obarray}, an error is signalled.")
939 #define FUNC_NAME s_scm_symbol_binding
943 scm_c_issue_deprecation_warning ("`symbol-binding' is deprecated. "
944 "Use hashtables instead.");
946 SCM_VALIDATE_SYMBOL (2,s
);
948 return scm_variable_ref (scm_lookup (s
));
949 SCM_VALIDATE_VECTOR (1,o
);
950 vcell
= scm_sym2ovcell (s
, o
);
951 return SCM_CDR(vcell
);
956 SCM_DEFINE (scm_symbol_interned_p
, "symbol-interned?", 2, 0, 0,
958 "Return @code{#t} if @var{obarray} contains a symbol with name\n"
959 "@var{string}, and @code{#f} otherwise.")
960 #define FUNC_NAME s_scm_symbol_interned_p
964 scm_c_issue_deprecation_warning ("`symbol-interned?' is deprecated. "
965 "Use hashtables instead.");
967 SCM_VALIDATE_SYMBOL (2,s
);
970 SCM var
= scm_sym2var (s
, SCM_BOOL_F
, SCM_BOOL_F
);
971 if (var
!= SCM_BOOL_F
)
975 SCM_VALIDATE_VECTOR (1,o
);
976 vcell
= scm_sym2ovcell_soft (s
, o
);
977 return (SCM_NIMP(vcell
)
984 SCM_DEFINE (scm_symbol_bound_p
, "symbol-bound?", 2, 0, 0,
986 "Return @code{#t} if @var{obarray} contains a symbol with name\n"
987 "@var{string} bound to a defined value. This differs from\n"
988 "@var{symbol-interned?} in that the mere mention of a symbol\n"
989 "usually causes it to be interned; @code{symbol-bound?}\n"
990 "determines whether a symbol has been given any meaningful\n"
992 #define FUNC_NAME s_scm_symbol_bound_p
996 scm_c_issue_deprecation_warning ("`symbol-bound?' is deprecated. "
997 "Use hashtables instead.");
999 SCM_VALIDATE_SYMBOL (2,s
);
1002 SCM var
= scm_sym2var (s
, SCM_BOOL_F
, SCM_BOOL_F
);
1003 if (SCM_VARIABLEP(var
) && !SCM_UNBNDP(SCM_VARIABLE_REF(var
)))
1007 SCM_VALIDATE_VECTOR (1,o
);
1008 vcell
= scm_sym2ovcell_soft (s
, o
);
1009 return SCM_BOOL (SCM_NIMP (vcell
) && !SCM_UNBNDP (SCM_CDR (vcell
)));
1014 SCM_DEFINE (scm_symbol_set_x
, "symbol-set!", 3, 0, 0,
1015 (SCM o
, SCM s
, SCM v
),
1016 "Find the symbol in @var{obarray} whose name is @var{string}, and rebind\n"
1017 "it to @var{value}. An error is signalled if @var{string} is not present\n"
1018 "in @var{obarray}.")
1019 #define FUNC_NAME s_scm_symbol_set_x
1023 scm_c_issue_deprecation_warning ("`symbol-set!' is deprecated. "
1024 "Use the module system instead.");
1026 SCM_VALIDATE_SYMBOL (2,s
);
1030 return SCM_UNSPECIFIED
;
1032 SCM_VALIDATE_VECTOR (1,o
);
1033 vcell
= scm_sym2ovcell (s
, o
);
1034 SCM_SETCDR (vcell
, v
);
1035 return SCM_UNSPECIFIED
;
1039 #define MAX_PREFIX_LENGTH 30
1041 static int gentemp_counter
;
1043 SCM_DEFINE (scm_gentemp
, "gentemp", 0, 2, 0,
1044 (SCM prefix
, SCM obarray
),
1045 "Create a new symbol with a name unique in an obarray.\n"
1046 "The name is constructed from an optional string @var{prefix}\n"
1047 "and a counter value. The default prefix is @code{t}. The\n"
1048 "@var{obarray} is specified as a second optional argument.\n"
1049 "Default is the system obarray where all normal symbols are\n"
1050 "interned. The counter is increased by 1 at each\n"
1051 "call. There is no provision for resetting the counter.")
1052 #define FUNC_NAME s_scm_gentemp
1054 char buf
[MAX_PREFIX_LENGTH
+ SCM_INTBUFLEN
];
1058 scm_c_issue_deprecation_warning ("`gentemp' is deprecated. "
1059 "Use `gensym' instead.");
1061 if (SCM_UNBNDP (prefix
))
1068 SCM_VALIDATE_STRING (1, prefix
);
1069 len
= SCM_STRING_LENGTH (prefix
);
1070 if (len
> MAX_PREFIX_LENGTH
)
1071 name
= SCM_MUST_MALLOC (MAX_PREFIX_LENGTH
+ SCM_INTBUFLEN
);
1072 strncpy (name
, SCM_STRING_CHARS (prefix
), len
);
1075 if (SCM_UNBNDP (obarray
))
1076 return scm_gensym (prefix
);
1078 SCM_ASSERT ((SCM_VECTORP (obarray
) || SCM_WVECTP (obarray
)),
1083 n_digits
= scm_iint2str (gentemp_counter
++, 10, &name
[len
]);
1084 while (!SCM_FALSEP (scm_intern_obarray_soft (name
,
1089 SCM vcell
= scm_intern_obarray_soft (name
,
1094 scm_must_free (name
);
1095 return SCM_CAR (vcell
);
1101 scm_i_init_deprecated ()
1103 #include "libguile/deprecated.x"