1 /* This file contains definitions for deprecated features. When you
2 deprecate something, move it here when that is feasible.
5 /* Copyright (C) 2003, 2004, 2006, 2008, 2009 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 License
9 * as published by the Free Software Foundation; either version 3 of
10 * the License, or (at your option) any later version.
12 * This library is distributed in the hope that it will be useful, but
13 * 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., 51 Franklin Street, Fifth Floor, Boston, MA
27 #include "libguile/_scm.h"
28 #include "libguile/async.h"
29 #include "libguile/deprecated.h"
30 #include "libguile/discouraged.h"
31 #include "libguile/deprecation.h"
32 #include "libguile/snarf.h"
33 #include "libguile/validate.h"
34 #include "libguile/strings.h"
35 #include "libguile/srfi-13.h"
36 #include "libguile/modules.h"
37 #include "libguile/generalized-arrays.h"
38 #include "libguile/eval.h"
39 #include "libguile/smob.h"
40 #include "libguile/procprop.h"
41 #include "libguile/vectors.h"
42 #include "libguile/hashtab.h"
43 #include "libguile/struct.h"
44 #include "libguile/variable.h"
45 #include "libguile/fluids.h"
46 #include "libguile/ports.h"
47 #include "libguile/eq.h"
48 #include "libguile/read.h"
49 #include "libguile/strports.h"
50 #include "libguile/smob.h"
51 #include "libguile/alist.h"
52 #include "libguile/keywords.h"
53 #include "libguile/feature.h"
58 #if (SCM_ENABLE_DEPRECATED == 1)
60 /* From print.c: Internal symbol names of isyms. Deprecated in guile 1.7.0 on
62 char *scm_isymnames
[] =
68 /* From eval.c: Error messages of the evaluator. These were deprecated in
69 * guile 1.7.0 on 2003-06-02. */
70 const char scm_s_expression
[] = "missing or extra expression";
71 const char scm_s_test
[] = "bad test";
72 const char scm_s_body
[] = "bad body";
73 const char scm_s_bindings
[] = "bad bindings";
74 const char scm_s_variable
[] = "bad variable";
75 const char scm_s_clauses
[] = "bad or missing clauses";
76 const char scm_s_formals
[] = "bad formals";
79 SCM_REGISTER_PROC(s_substring_move_left_x
, "substring-move-left!", 5, 0, 0, scm_substring_move_x
);
81 SCM_REGISTER_PROC(s_substring_move_right_x
, "substring-move-right!", 5, 0, 0, scm_substring_move_x
);
84 scm_wta (SCM arg
, const char *pos
, const char *s_subr
)
86 if (!s_subr
|| !*s_subr
)
88 if ((~0x1fL
) & (long) pos
)
90 /* error string supplied. */
91 scm_misc_error (s_subr
, pos
, scm_list_1 (arg
));
95 /* numerical error code. */
96 scm_t_bits error
= (scm_t_bits
) pos
;
101 scm_wrong_type_arg (s_subr
, 0, arg
);
103 scm_wrong_type_arg (s_subr
, 1, arg
);
105 scm_wrong_type_arg (s_subr
, 2, arg
);
107 scm_wrong_type_arg (s_subr
, 3, arg
);
109 scm_wrong_type_arg (s_subr
, 4, arg
);
111 scm_wrong_type_arg (s_subr
, 5, arg
);
113 scm_wrong_type_arg (s_subr
, 6, arg
);
115 scm_wrong_type_arg (s_subr
, 7, arg
);
117 scm_wrong_num_args (arg
);
119 scm_out_of_range (s_subr
, arg
);
121 scm_memory_error (s_subr
);
123 /* this shouldn't happen. */
124 scm_misc_error (s_subr
, "Unknown error", SCM_EOL
);
127 return SCM_UNSPECIFIED
;
133 /* We can't use SCM objects here. One should be able to call
134 SCM_REGISTER_MODULE from a C++ constructor for a static
135 object. This happens before main and thus before libguile is
139 struct moddata
*link
;
144 static struct moddata
*registered_mods
= NULL
;
147 scm_register_module_xxx (char *module_name
, void *init_func
)
151 scm_c_issue_deprecation_warning
152 ("`scm_register_module_xxx' is deprecated. Use extensions instead.");
154 /* XXX - should we (and can we) DEFER_INTS here? */
156 for (md
= registered_mods
; md
; md
= md
->link
)
157 if (!strcmp (md
->module_name
, module_name
))
159 md
->init_func
= init_func
;
163 md
= (struct moddata
*) malloc (sizeof (struct moddata
));
167 "guile: can't register module (%s): not enough memory",
172 md
->module_name
= module_name
;
173 md
->init_func
= init_func
;
174 md
->link
= registered_mods
;
175 registered_mods
= md
;
178 SCM_DEFINE (scm_registered_modules
, "c-registered-modules", 0, 0, 0,
180 "Return a list of the object code modules that have been imported into\n"
181 "the current Guile process. Each element of the list is a pair whose\n"
182 "car is the name of the module, and whose cdr is the function handle\n"
183 "for that module's initializer function. The name is the string that\n"
184 "has been passed to scm_register_module_xxx.")
185 #define FUNC_NAME s_scm_registered_modules
191 for (md
= registered_mods
; md
; md
= md
->link
)
192 res
= scm_cons (scm_cons (scm_from_locale_string (md
->module_name
),
193 scm_from_ulong ((unsigned long) md
->init_func
)),
199 SCM_DEFINE (scm_clear_registered_modules
, "c-clear-registered-modules", 0, 0, 0,
201 "Destroy the list of modules registered with the current Guile process.\n"
202 "The return value is unspecified. @strong{Warning:} this function does\n"
203 "not actually unlink or deallocate these modules, but only destroys the\n"
204 "records of which modules have been loaded. It should therefore be used\n"
205 "only by module bookkeeping operations.")
206 #define FUNC_NAME s_scm_clear_registered_modules
208 struct moddata
*md1
, *md2
;
210 SCM_CRITICAL_SECTION_START
;
212 for (md1
= registered_mods
; md1
; md1
= md2
)
217 registered_mods
= NULL
;
219 SCM_CRITICAL_SECTION_END
;
220 return SCM_UNSPECIFIED
;
225 scm_remember (SCM
*ptr
)
227 scm_c_issue_deprecation_warning ("`scm_remember' is deprecated. "
228 "Use the `scm_remember_upto_here*' family of functions instead.");
232 scm_protect_object (SCM obj
)
234 scm_c_issue_deprecation_warning ("`scm_protect_object' is deprecated. "
235 "Use `scm_gc_protect_object' instead.");
236 return scm_gc_protect_object (obj
);
240 scm_unprotect_object (SCM obj
)
242 scm_c_issue_deprecation_warning ("`scm_unprotect_object' is deprecated. "
243 "Use `scm_gc_unprotect_object' instead.");
244 return scm_gc_unprotect_object (obj
);
247 SCM_SYMBOL (scm_sym_app
, "app");
248 SCM_SYMBOL (scm_sym_modules
, "modules");
249 static SCM module_prefix
= SCM_BOOL_F
;
250 static SCM make_modules_in_var
;
251 static SCM beautify_user_module_x_var
;
252 static SCM try_module_autoload_var
;
257 #define PERM(x) scm_permanent_object(x)
259 if (module_prefix
== SCM_BOOL_F
)
261 module_prefix
= PERM (scm_list_2 (scm_sym_app
, scm_sym_modules
));
262 make_modules_in_var
= PERM (scm_c_lookup ("make-modules-in"));
263 beautify_user_module_x_var
=
264 PERM (scm_c_lookup ("beautify-user-module!"));
265 try_module_autoload_var
= PERM (scm_c_lookup ("try-module-autoload"));
270 scm_the_root_module ()
272 init_module_stuff ();
273 scm_c_issue_deprecation_warning ("`scm_the_root_module' is deprecated. "
274 "Use `scm_c_resolve_module (\"guile\")' "
277 return scm_c_resolve_module ("guile");
281 scm_module_full_name (SCM name
)
283 init_module_stuff ();
284 if (scm_is_eq (SCM_CAR (name
), scm_sym_app
))
287 return scm_append (scm_list_2 (module_prefix
, name
));
291 scm_make_module (SCM name
)
293 init_module_stuff ();
294 scm_c_issue_deprecation_warning ("`scm_make_module' is deprecated. "
295 "Use `scm_c_define_module instead.");
297 return scm_call_2 (SCM_VARIABLE_REF (make_modules_in_var
),
298 scm_the_root_module (),
299 scm_module_full_name (name
));
303 scm_ensure_user_module (SCM module
)
305 init_module_stuff ();
306 scm_c_issue_deprecation_warning ("`scm_ensure_user_module' is deprecated. "
307 "Use `scm_c_define_module instead.");
309 scm_call_1 (SCM_VARIABLE_REF (beautify_user_module_x_var
), module
);
310 return SCM_UNSPECIFIED
;
314 scm_load_scheme_module (SCM name
)
316 init_module_stuff ();
317 scm_c_issue_deprecation_warning ("`scm_load_scheme_module' is deprecated. "
318 "Use `scm_c_resolve_module instead.");
320 return scm_call_1 (SCM_VARIABLE_REF (try_module_autoload_var
), name
);
323 /* This is implemented in C solely for SCM_COERCE_OUTPORT ... */
326 maybe_close_port (void *data
, SCM port
)
328 SCM except_set
= (SCM
) data
;
330 while (!scm_is_null (except_set
))
332 SCM p
= SCM_COERCE_OUTPORT (SCM_CAR (except_set
));
333 if (scm_is_eq (p
, port
))
335 except_set
= SCM_CDR (except_set
);
338 scm_close_port (port
);
341 SCM_DEFINE (scm_close_all_ports_except
, "close-all-ports-except", 0, 0, 1,
343 "[DEPRECATED] Close all open file ports used by the interpreter\n"
344 "except for those supplied as arguments. This procedure\n"
345 "was intended to be used before an exec call to close file descriptors\n"
346 "which are not needed in the new process. However it has the\n"
347 "undesirable side effect of flushing buffers, so it's deprecated.\n"
348 "Use port-for-each instead.")
349 #define FUNC_NAME s_scm_close_all_ports_except
352 SCM_VALIDATE_REST_ARGUMENT (ports
);
354 for (p
= ports
; !scm_is_null (p
); p
= SCM_CDR (p
))
355 SCM_VALIDATE_OPPORT (SCM_ARG1
, SCM_COERCE_OUTPORT (SCM_CAR (p
)));
357 scm_c_port_for_each (maybe_close_port
, ports
);
359 return SCM_UNSPECIFIED
;
363 SCM_DEFINE (scm_variable_set_name_hint
, "variable-set-name-hint!", 2, 0, 0,
365 "Do not use this function.")
366 #define FUNC_NAME s_scm_variable_set_name_hint
368 SCM_VALIDATE_VARIABLE (1, var
);
369 SCM_VALIDATE_SYMBOL (2, hint
);
370 scm_c_issue_deprecation_warning
371 ("'variable-set-name-hint!' is deprecated. Do not use it.");
372 return SCM_UNSPECIFIED
;
376 SCM_DEFINE (scm_builtin_variable
, "builtin-variable", 1, 0, 0,
378 "Do not use this function.")
379 #define FUNC_NAME s_scm_builtin_variable
381 SCM_VALIDATE_SYMBOL (1,name
);
382 scm_c_issue_deprecation_warning ("`builtin-variable' is deprecated. "
383 "Use module system operations instead.");
384 return scm_sym2var (name
, SCM_BOOL_F
, SCM_BOOL_T
);
389 scm_makstr (size_t len
, int dummy
)
391 scm_c_issue_deprecation_warning
392 ("'scm_makstr' is deprecated. Use 'scm_c_make_string' instead.");
393 return scm_c_make_string (len
, SCM_UNDEFINED
);
397 scm_makfromstr (const char *src
, size_t len
, int dummy SCM_UNUSED
)
399 scm_c_issue_deprecation_warning ("`scm_makfromstr' is deprecated. "
400 "Use `scm_from_locale_stringn' instead.");
402 return scm_from_locale_stringn (src
, len
);
406 scm_internal_with_fluids (SCM fluids
, SCM values
, SCM (*cproc
) (), void *cdata
)
408 scm_c_issue_deprecation_warning ("`scm_internal_with_fluids' is deprecated. "
409 "Use `scm_c_with_fluids' instead.");
411 return scm_c_with_fluids (fluids
, values
, cproc
, cdata
);
415 scm_make_gsubr (const char *name
, int req
, int opt
, int rst
, SCM (*fcn
)())
417 scm_c_issue_deprecation_warning
418 ("`scm_make_gsubr' is deprecated. Use `scm_c_define_gsubr' instead.");
420 return scm_c_define_gsubr (name
, req
, opt
, rst
, fcn
);
424 scm_make_gsubr_with_generic (const char *name
,
425 int req
, int opt
, int rst
,
426 SCM (*fcn
)(), SCM
*gf
)
428 scm_c_issue_deprecation_warning
429 ("`scm_make_gsubr_with_generic' is deprecated. "
430 "Use `scm_c_define_gsubr_with_generic' instead.");
432 return scm_c_define_gsubr_with_generic (name
, req
, opt
, rst
, fcn
, gf
);
436 scm_create_hook (const char *name
, int n_args
)
438 scm_c_issue_deprecation_warning
439 ("'scm_create_hook' is deprecated. "
440 "Use 'scm_make_hook' and 'scm_c_define' instead.");
442 SCM hook
= scm_make_hook (scm_from_int (n_args
));
443 scm_c_define (name
, hook
);
444 return scm_permanent_object (hook
);
448 SCM_DEFINE (scm_sloppy_memq
, "sloppy-memq", 2, 0, 0,
450 "This procedure behaves like @code{memq}, but does no type or error checking.\n"
451 "Its use is recommended only in writing Guile internals,\n"
452 "not for high-level Scheme programs.")
453 #define FUNC_NAME s_scm_sloppy_memq
455 scm_c_issue_deprecation_warning
456 ("'sloppy-memq' is deprecated. Use 'memq' instead.");
458 for(; scm_is_pair (lst
); lst
= SCM_CDR(lst
))
460 if (scm_is_eq (SCM_CAR (lst
), x
))
468 SCM_DEFINE (scm_sloppy_memv
, "sloppy-memv", 2, 0, 0,
470 "This procedure behaves like @code{memv}, but does no type or error checking.\n"
471 "Its use is recommended only in writing Guile internals,\n"
472 "not for high-level Scheme programs.")
473 #define FUNC_NAME s_scm_sloppy_memv
475 scm_c_issue_deprecation_warning
476 ("'sloppy-memv' is deprecated. Use 'memv' instead.");
478 for(; scm_is_pair (lst
); lst
= SCM_CDR(lst
))
480 if (! scm_is_false (scm_eqv_p (SCM_CAR (lst
), x
)))
488 SCM_DEFINE (scm_sloppy_member
, "sloppy-member", 2, 0, 0,
490 "This procedure behaves like @code{member}, but does no type or error checking.\n"
491 "Its use is recommended only in writing Guile internals,\n"
492 "not for high-level Scheme programs.")
493 #define FUNC_NAME s_scm_sloppy_member
495 scm_c_issue_deprecation_warning
496 ("'sloppy-member' is deprecated. Use 'member' instead.");
498 for(; scm_is_pair (lst
); lst
= SCM_CDR(lst
))
500 if (! scm_is_false (scm_equal_p (SCM_CAR (lst
), x
)))
507 SCM_SYMBOL (scm_end_of_file_key
, "end-of-file");
509 SCM_DEFINE (scm_read_and_eval_x
, "read-and-eval!", 0, 1, 0,
511 "Read a form from @var{port} (standard input by default), and evaluate it\n"
512 "(memoizing it in the process) in the top-level environment. If no data\n"
513 "is left to be read from @var{port}, an @code{end-of-file} error is\n"
515 #define FUNC_NAME s_scm_read_and_eval_x
519 scm_c_issue_deprecation_warning
520 ("'read-and-eval!' is deprecated. Use 'read' and 'eval' instead.");
522 form
= scm_read (port
);
523 if (SCM_EOF_OBJECT_P (form
))
524 scm_ithrow (scm_end_of_file_key
, SCM_EOL
, 1);
525 return scm_eval_x (form
, scm_current_module ());
530 scm_make_subr_opt (const char *name
, int type
, SCM (*fcn
) (), int set
)
532 scm_c_issue_deprecation_warning
533 ("`scm_make_subr_opt' is deprecated. Use `scm_c_make_subr' or "
534 "`scm_c_define_subr' instead.");
537 return scm_c_define_subr (name
, type
, fcn
);
539 return scm_c_make_subr (name
, type
, fcn
);
543 scm_make_subr (const char *name
, int type
, SCM (*fcn
) ())
545 scm_c_issue_deprecation_warning
546 ("`scm_make_subr' is deprecated. Use `scm_c_define_subr' instead.");
548 return scm_c_define_subr (name
, type
, fcn
);
552 scm_make_subr_with_generic (const char *name
, int type
, SCM (*fcn
) (), SCM
*gf
)
554 scm_c_issue_deprecation_warning
555 ("`scm_make_subr_with_generic' is deprecated. Use "
556 "`scm_c_define_subr_with_generic' instead.");
558 return scm_c_define_subr_with_generic (name
, type
, fcn
, gf
);
561 /* Call thunk(closure) underneath a top-level error handler.
562 * If an error occurs, pass the exitval through err_filter and return it.
563 * If no error occurs, return the value of thunk.
567 typedef int setjmp_type
;
569 typedef long setjmp_type
;
572 struct cce_handler_data
{
573 SCM (*err_filter
) ();
578 invoke_err_filter (void *d
, SCM tag
, SCM args
)
580 struct cce_handler_data
*data
= (struct cce_handler_data
*)d
;
581 return data
->err_filter (SCM_BOOL_F
, data
->closure
);
585 scm_call_catching_errors (SCM (*thunk
)(), SCM (*err_filter
)(), void *closure
)
587 scm_c_issue_deprecation_warning
588 ("'scm_call_catching_errors' is deprecated. "
589 "Use 'scm_internal_catch' instead.");
592 struct cce_handler_data data
;
593 data
.err_filter
= err_filter
;
594 data
.closure
= closure
;
595 return scm_internal_catch (SCM_BOOL_T
,
596 (scm_t_catch_body
)thunk
, closure
,
597 (scm_t_catch_handler
)invoke_err_filter
, &data
);
602 scm_make_smob_type_mfpe (char *name
, size_t size
,
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_make_smob_type_mfpe' is deprecated. "
610 "Use 'scm_make_smob_type' plus 'scm_set_smob_*' instead.");
613 long answer
= scm_make_smob_type (name
, size
);
614 scm_set_smob_mfpe (answer
, mark
, free
, print
, equalp
);
620 scm_set_smob_mfpe (long tc
,
622 size_t (*free
) (SCM
),
623 int (*print
) (SCM
, SCM
, scm_print_state
*),
624 SCM (*equalp
) (SCM
, SCM
))
626 scm_c_issue_deprecation_warning
627 ("'scm_set_smob_mfpe' is deprecated. "
628 "Use 'scm_set_smob_mark' instead, for example.");
630 if (mark
) scm_set_smob_mark (tc
, mark
);
631 if (free
) scm_set_smob_free (tc
, free
);
632 if (print
) scm_set_smob_print (tc
, print
);
633 if (equalp
) scm_set_smob_equalp (tc
, equalp
);
637 scm_smob_free (SCM obj
)
639 long n
= SCM_SMOBNUM (obj
);
641 scm_c_issue_deprecation_warning
642 ("`scm_smob_free' is deprecated. "
643 "It is no longer needed.");
645 if (scm_smobs
[n
].size
> 0)
646 scm_gc_free ((void *) SCM_CELL_WORD_1 (obj
),
647 scm_smobs
[n
].size
, SCM_SMOBNAME (n
));
652 scm_read_0str (char *expr
)
654 scm_c_issue_deprecation_warning
655 ("scm_read_0str is deprecated. Use scm_c_read_string instead.");
657 return scm_c_read_string (expr
);
661 scm_eval_0str (const char *expr
)
663 scm_c_issue_deprecation_warning
664 ("scm_eval_0str is deprecated. Use scm_c_eval_string instead.");
666 return scm_c_eval_string (expr
);
670 scm_strprint_obj (SCM obj
)
672 scm_c_issue_deprecation_warning
673 ("scm_strprint_obj is deprecated. Use scm_object_to_string instead.");
674 return scm_object_to_string (obj
, SCM_UNDEFINED
);
678 scm_i_object_chars (SCM obj
)
680 scm_c_issue_deprecation_warning
681 ("SCM_CHARS is deprecated. See the manual for alternatives.");
682 if (SCM_STRINGP (obj
))
683 return SCM_STRING_CHARS (obj
);
684 if (SCM_SYMBOLP (obj
))
685 return SCM_SYMBOL_CHARS (obj
);
690 scm_i_object_length (SCM obj
)
692 scm_c_issue_deprecation_warning
693 ("SCM_LENGTH is deprecated. "
694 "Use scm_c_string_length instead, for example, or see the manual.");
695 if (SCM_STRINGP (obj
))
696 return SCM_STRING_LENGTH (obj
);
697 if (SCM_SYMBOLP (obj
))
698 return SCM_SYMBOL_LENGTH (obj
);
699 if (SCM_VECTORP (obj
))
700 return SCM_VECTOR_LENGTH (obj
);
705 scm_sym2ovcell_soft (SCM sym
, SCM obarray
)
708 size_t hash
= scm_i_symbol_hash (sym
) % SCM_VECTOR_LENGTH (obarray
);
710 scm_c_issue_deprecation_warning ("`scm_sym2ovcell_soft' is deprecated. "
711 "Use hashtables instead.");
713 SCM_CRITICAL_SECTION_START
;
714 for (lsym
= SCM_VECTOR_REF (obarray
, hash
);
716 lsym
= SCM_CDR (lsym
))
719 if (scm_is_eq (SCM_CAR (z
), sym
))
721 SCM_CRITICAL_SECTION_END
;
725 SCM_CRITICAL_SECTION_END
;
731 scm_sym2ovcell (SCM sym
, SCM obarray
)
732 #define FUNC_NAME "scm_sym2ovcell"
736 scm_c_issue_deprecation_warning ("`scm_sym2ovcell' is deprecated. "
737 "Use hashtables instead.");
739 answer
= scm_sym2ovcell_soft (sym
, obarray
);
740 if (scm_is_true (answer
))
742 SCM_MISC_ERROR ("uninterned symbol: ~S", scm_list_1 (sym
));
743 return SCM_UNSPECIFIED
; /* not reached */
748 /* Intern a symbol whose name is the LEN characters at NAME in OBARRAY.
750 OBARRAY should be a vector of lists, indexed by the name's hash
751 value, modulo OBARRAY's length. Each list has the form
752 ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the
753 value associated with that symbol (in the current module? in the
756 To "intern" a symbol means: if OBARRAY already contains a symbol by
757 that name, return its (SYMBOL . VALUE) pair; otherwise, create a
758 new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the
759 appropriate list of the OBARRAY, and return the pair.
761 If softness is non-zero, don't create a symbol if it isn't already
762 in OBARRAY; instead, just return #f.
764 If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and
765 return (SYMBOL . SCM_UNDEFINED). */
769 intern_obarray_soft (SCM symbol
, SCM obarray
, unsigned int softness
)
771 size_t raw_hash
= scm_i_symbol_hash (symbol
);
775 if (scm_is_false (obarray
))
780 return scm_cons (symbol
, SCM_UNDEFINED
);
783 hash
= raw_hash
% SCM_VECTOR_LENGTH (obarray
);
785 for (lsym
= SCM_VECTOR_REF(obarray
, hash
);
786 SCM_NIMP (lsym
); lsym
= SCM_CDR (lsym
))
788 SCM a
= SCM_CAR (lsym
);
790 if (scm_is_eq (z
, symbol
))
800 SCM cell
= scm_cons (symbol
, SCM_UNDEFINED
);
801 SCM slot
= SCM_VECTOR_REF (obarray
, hash
);
803 SCM_VECTOR_SET (obarray
, hash
, scm_cons (cell
, slot
));
811 scm_intern_obarray_soft (const char *name
, size_t len
, SCM obarray
,
812 unsigned int softness
)
814 SCM symbol
= scm_from_locale_symboln (name
, len
);
816 scm_c_issue_deprecation_warning ("`scm_intern_obarray_soft' is deprecated. "
817 "Use hashtables instead.");
819 return intern_obarray_soft (symbol
, obarray
, softness
);
823 scm_intern_obarray (const char *name
,size_t len
,SCM obarray
)
825 scm_c_issue_deprecation_warning ("`scm_intern_obarray' is deprecated. "
826 "Use hashtables instead.");
828 return scm_intern_obarray_soft (name
, len
, obarray
, 0);
831 /* Lookup the value of the symbol named by the nul-terminated string
832 NAME in the current module. */
834 scm_symbol_value0 (const char *name
)
836 scm_c_issue_deprecation_warning ("`scm_symbol_value0' is deprecated. "
837 "Use `scm_lookup' instead.");
839 return scm_variable_ref (scm_c_lookup (name
));
842 SCM_DEFINE (scm_string_to_obarray_symbol
, "string->obarray-symbol", 2, 1, 0,
843 (SCM o
, SCM s
, SCM softp
),
844 "Intern a new symbol in @var{obarray}, a symbol table, with name\n"
846 "If @var{obarray} is @code{#f}, use the default system symbol table. If\n"
847 "@var{obarray} is @code{#t}, the symbol should not be interned in any\n"
848 "symbol table; merely return the pair (@var{symbol}\n"
849 ". @var{#<undefined>}).\n\n"
850 "The @var{soft?} argument determines whether new symbol table entries\n"
851 "should be created when the specified symbol is not already present in\n"
852 "@var{obarray}. If @var{soft?} is specified and is a true value, then\n"
853 "new entries should not be added for symbols not already present in the\n"
854 "table; instead, simply return @code{#f}.")
855 #define FUNC_NAME s_scm_string_to_obarray_symbol
861 SCM_VALIDATE_STRING (2, s
);
862 SCM_ASSERT (scm_is_bool (o
) || SCM_VECTORP (o
), o
, SCM_ARG1
, FUNC_NAME
);
864 scm_c_issue_deprecation_warning ("`string->obarray-symbol' is deprecated. "
865 "Use hashtables instead.");
867 softness
= (!SCM_UNBNDP (softp
) && scm_is_true(softp
));
868 /* iron out some screwy calling conventions */
869 if (scm_is_false (o
))
871 /* nothing interesting to do here. */
872 return scm_string_to_symbol (s
);
874 else if (scm_is_eq (o
, SCM_BOOL_T
))
877 vcell
= intern_obarray_soft (scm_string_to_symbol (s
), o
, softness
);
878 if (scm_is_false (vcell
))
880 answer
= SCM_CAR (vcell
);
885 SCM_DEFINE (scm_intern_symbol
, "intern-symbol", 2, 0, 0,
887 "Add a new symbol to @var{obarray} with name @var{string}, bound to an\n"
888 "unspecified initial value. The symbol table is not modified if a symbol\n"
889 "with this name is already present.")
890 #define FUNC_NAME s_scm_intern_symbol
893 SCM_VALIDATE_SYMBOL (2,s
);
894 if (scm_is_false (o
))
895 return SCM_UNSPECIFIED
;
897 scm_c_issue_deprecation_warning ("`intern-symbol' is deprecated. "
898 "Use hashtables instead.");
900 SCM_VALIDATE_VECTOR (1,o
);
901 hval
= scm_i_symbol_hash (s
) % SCM_VECTOR_LENGTH (o
);
902 /* If the symbol is already interned, simply return. */
903 SCM_CRITICAL_SECTION_START
;
907 for (lsym
= SCM_VECTOR_REF (o
, hval
);
909 lsym
= SCM_CDR (lsym
))
911 sym
= SCM_CAR (lsym
);
912 if (scm_is_eq (SCM_CAR (sym
), s
))
914 SCM_CRITICAL_SECTION_END
;
915 return SCM_UNSPECIFIED
;
918 SCM_VECTOR_SET (o
, hval
,
919 scm_acons (s
, SCM_UNDEFINED
,
920 SCM_VECTOR_REF (o
, hval
)));
922 SCM_CRITICAL_SECTION_END
;
923 return SCM_UNSPECIFIED
;
927 SCM_DEFINE (scm_unintern_symbol
, "unintern-symbol", 2, 0, 0,
929 "Remove the symbol with name @var{string} from @var{obarray}. This\n"
930 "function returns @code{#t} if the symbol was present and @code{#f}\n"
932 #define FUNC_NAME s_scm_unintern_symbol
936 scm_c_issue_deprecation_warning ("`unintern-symbol' is deprecated. "
937 "Use hashtables instead.");
939 SCM_VALIDATE_SYMBOL (2,s
);
940 if (scm_is_false (o
))
942 SCM_VALIDATE_VECTOR (1,o
);
943 hval
= scm_i_symbol_hash (s
) % SCM_VECTOR_LENGTH (o
);
944 SCM_CRITICAL_SECTION_START
;
949 for (lsym
= SCM_VECTOR_REF (o
, hval
), lsym_follow
= SCM_BOOL_F
;
951 lsym_follow
= lsym
, lsym
= SCM_CDR (lsym
))
953 sym
= SCM_CAR (lsym
);
954 if (scm_is_eq (SCM_CAR (sym
), s
))
956 /* Found the symbol to unintern. */
957 if (scm_is_false (lsym_follow
))
958 SCM_VECTOR_SET (o
, hval
, lsym
);
960 SCM_SETCDR (lsym_follow
, SCM_CDR(lsym
));
961 SCM_CRITICAL_SECTION_END
;
966 SCM_CRITICAL_SECTION_END
;
971 SCM_DEFINE (scm_symbol_binding
, "symbol-binding", 2, 0, 0,
973 "Look up in @var{obarray} the symbol whose name is @var{string}, and\n"
974 "return the value to which it is bound. If @var{obarray} is @code{#f},\n"
975 "use the global symbol table. If @var{string} is not interned in\n"
976 "@var{obarray}, an error is signalled.")
977 #define FUNC_NAME s_scm_symbol_binding
981 scm_c_issue_deprecation_warning ("`symbol-binding' is deprecated. "
982 "Use hashtables instead.");
984 SCM_VALIDATE_SYMBOL (2,s
);
985 if (scm_is_false (o
))
986 return scm_variable_ref (scm_lookup (s
));
987 SCM_VALIDATE_VECTOR (1,o
);
988 vcell
= scm_sym2ovcell (s
, o
);
989 return SCM_CDR(vcell
);
994 SCM_DEFINE (scm_symbol_interned_p
, "symbol-interned?", 2, 0, 0,
996 "Return @code{#t} if @var{obarray} contains a symbol with name\n"
997 "@var{string}, and @code{#f} otherwise.")
998 #define FUNC_NAME s_scm_symbol_interned_p
1002 scm_c_issue_deprecation_warning ("`symbol-interned?' is deprecated. "
1003 "Use hashtables instead.");
1005 SCM_VALIDATE_SYMBOL (2,s
);
1006 if (scm_is_false (o
))
1008 SCM var
= scm_sym2var (s
, SCM_BOOL_F
, SCM_BOOL_F
);
1009 if (var
!= SCM_BOOL_F
)
1013 SCM_VALIDATE_VECTOR (1,o
);
1014 vcell
= scm_sym2ovcell_soft (s
, o
);
1015 return (SCM_NIMP(vcell
)
1022 SCM_DEFINE (scm_symbol_bound_p
, "symbol-bound?", 2, 0, 0,
1024 "Return @code{#t} if @var{obarray} contains a symbol with name\n"
1025 "@var{string} bound to a defined value. This differs from\n"
1026 "@var{symbol-interned?} in that the mere mention of a symbol\n"
1027 "usually causes it to be interned; @code{symbol-bound?}\n"
1028 "determines whether a symbol has been given any meaningful\n"
1030 #define FUNC_NAME s_scm_symbol_bound_p
1034 scm_c_issue_deprecation_warning ("`symbol-bound?' is deprecated. "
1035 "Use hashtables instead.");
1037 SCM_VALIDATE_SYMBOL (2,s
);
1038 if (scm_is_false (o
))
1040 SCM var
= scm_sym2var (s
, SCM_BOOL_F
, SCM_BOOL_F
);
1041 if (SCM_VARIABLEP(var
) && !SCM_UNBNDP(SCM_VARIABLE_REF(var
)))
1045 SCM_VALIDATE_VECTOR (1,o
);
1046 vcell
= scm_sym2ovcell_soft (s
, o
);
1047 return scm_from_bool (SCM_NIMP (vcell
) && !SCM_UNBNDP (SCM_CDR (vcell
)));
1052 SCM_DEFINE (scm_symbol_set_x
, "symbol-set!", 3, 0, 0,
1053 (SCM o
, SCM s
, SCM v
),
1054 "Find the symbol in @var{obarray} whose name is @var{string}, and rebind\n"
1055 "it to @var{value}. An error is signalled if @var{string} is not present\n"
1056 "in @var{obarray}.")
1057 #define FUNC_NAME s_scm_symbol_set_x
1061 scm_c_issue_deprecation_warning ("`symbol-set!' is deprecated. "
1062 "Use the module system instead.");
1064 SCM_VALIDATE_SYMBOL (2,s
);
1065 if (scm_is_false (o
))
1068 return SCM_UNSPECIFIED
;
1070 SCM_VALIDATE_VECTOR (1,o
);
1071 vcell
= scm_sym2ovcell (s
, o
);
1072 SCM_SETCDR (vcell
, v
);
1073 return SCM_UNSPECIFIED
;
1077 #define MAX_PREFIX_LENGTH 30
1079 static int gentemp_counter
;
1081 SCM_DEFINE (scm_gentemp
, "gentemp", 0, 2, 0,
1082 (SCM prefix
, SCM obarray
),
1083 "Create a new symbol with a name unique in an obarray.\n"
1084 "The name is constructed from an optional string @var{prefix}\n"
1085 "and a counter value. The default prefix is @code{t}. The\n"
1086 "@var{obarray} is specified as a second optional argument.\n"
1087 "Default is the system obarray where all normal symbols are\n"
1088 "interned. The counter is increased by 1 at each\n"
1089 "call. There is no provision for resetting the counter.")
1090 #define FUNC_NAME s_scm_gentemp
1092 char buf
[MAX_PREFIX_LENGTH
+ SCM_INTBUFLEN
];
1097 scm_c_issue_deprecation_warning ("`gentemp' is deprecated. "
1098 "Use `gensym' instead.");
1100 if (SCM_UNBNDP (prefix
))
1107 SCM_VALIDATE_STRING (1, prefix
);
1108 len
= scm_i_string_length (prefix
);
1109 name
= scm_to_locale_stringn (prefix
, &len
);
1110 name
= scm_realloc (name
, len
+ SCM_INTBUFLEN
);
1113 if (SCM_UNBNDP (obarray
))
1114 return scm_gensym (prefix
);
1116 SCM_ASSERT ((scm_is_vector (obarray
) || SCM_I_WVECTP (obarray
)),
1121 n_digits
= scm_iint2str (gentemp_counter
++, 10, &name
[len
]);
1122 while (scm_is_true (scm_intern_obarray_soft (name
,
1127 SCM vcell
= scm_intern_obarray_soft (name
,
1133 return SCM_CAR (vcell
);
1139 scm_i_makinum (scm_t_signed_bits val
)
1141 scm_c_issue_deprecation_warning
1142 ("SCM_MAKINUM is deprecated. Use scm_from_int or similar instead.");
1143 return SCM_I_MAKINUM (val
);
1147 scm_i_inump (SCM obj
)
1149 scm_c_issue_deprecation_warning
1150 ("SCM_INUMP is deprecated. Use scm_is_integer or similar instead.");
1151 return SCM_I_INUMP (obj
);
1155 scm_i_inum (SCM obj
)
1157 scm_c_issue_deprecation_warning
1158 ("SCM_INUM is deprecated. Use scm_to_int or similar instead.");
1159 return scm_to_intmax (obj
);
1163 scm_c_string2str (SCM obj
, char *str
, size_t *lenp
)
1165 scm_c_issue_deprecation_warning
1166 ("scm_c_string2str is deprecated. Use scm_to_locale_stringbuf or similar instead.");
1170 char *result
= scm_to_locale_string (obj
);
1172 *lenp
= scm_i_string_length (obj
);
1177 /* Pray that STR is large enough.
1179 size_t len
= scm_to_locale_stringbuf (obj
, str
, SCM_I_SIZE_MAX
);
1188 scm_c_substring2str (SCM obj
, char *str
, size_t start
, size_t len
)
1190 scm_c_issue_deprecation_warning
1191 ("scm_c_substring2str is deprecated. Use scm_substring plus scm_to_locale_stringbuf instead.");
1194 obj
= scm_substring (obj
, scm_from_size_t (start
), SCM_UNDEFINED
);
1196 scm_to_locale_stringbuf (obj
, str
, len
);
1200 /* Converts the given Scheme symbol OBJ into a C string, containing a copy
1201 of OBJ's content with a trailing null byte. If LENP is non-NULL, set
1202 *LENP to the string's length.
1204 When STR is non-NULL it receives the copy and is returned by the function,
1205 otherwise new memory is allocated and the caller is responsible for
1206 freeing it via free(). If out of memory, NULL is returned.
1208 Note that Scheme symbols may contain arbitrary data, including null
1209 characters. This means that null termination is not a reliable way to
1210 determine the length of the returned value. However, the function always
1211 copies the complete contents of OBJ, and sets *LENP to the length of the
1212 scheme symbol (if LENP is non-null). */
1214 scm_c_symbol2str (SCM obj
, char *str
, size_t *lenp
)
1216 return scm_c_string2str (scm_symbol_to_string (obj
), str
, lenp
);
1220 scm_truncate (double x
)
1222 scm_c_issue_deprecation_warning
1223 ("scm_truncate is deprecated. Use scm_c_truncate instead.");
1224 return scm_c_truncate (x
);
1228 scm_round (double x
)
1230 scm_c_issue_deprecation_warning
1231 ("scm_round is deprecated. Use scm_c_round instead.");
1232 return scm_c_round (x
);
1236 scm_i_deprecated_symbol_chars (SCM sym
)
1238 scm_c_issue_deprecation_warning
1239 ("SCM_SYMBOL_CHARS is deprecated. Use scm_symbol_to_string.");
1241 return (char *)scm_i_symbol_chars (sym
);
1245 scm_i_deprecated_symbol_length (SCM sym
)
1247 scm_c_issue_deprecation_warning
1248 ("SCM_SYMBOL_LENGTH is deprecated. Use scm_symbol_to_string.");
1249 return scm_i_symbol_length (sym
);
1253 scm_i_keywordp (SCM obj
)
1255 scm_c_issue_deprecation_warning
1256 ("SCM_KEYWORDP is deprecated. Use scm_is_keyword instead.");
1257 return scm_is_keyword (obj
);
1261 scm_i_keywordsym (SCM keyword
)
1263 scm_c_issue_deprecation_warning
1264 ("SCM_KEYWORDSYM is deprecated. See scm_keyword_to_symbol instead.");
1265 return scm_keyword_dash_symbol (keyword
);
1269 scm_i_vectorp (SCM x
)
1271 scm_c_issue_deprecation_warning
1272 ("SCM_VECTORP is deprecated. Use scm_is_vector instead.");
1273 return SCM_I_IS_VECTOR (x
);
1277 scm_i_vector_length (SCM x
)
1279 scm_c_issue_deprecation_warning
1280 ("SCM_VECTOR_LENGTH is deprecated. Use scm_c_vector_length instead.");
1281 return SCM_I_VECTOR_LENGTH (x
);
1287 scm_c_issue_deprecation_warning
1288 ("SCM_VELTS is deprecated. Use scm_vector_elements instead.");
1289 return SCM_I_VECTOR_ELTS (x
);
1293 scm_i_writable_velts (SCM x
)
1295 scm_c_issue_deprecation_warning
1296 ("SCM_WRITABLE_VELTS is deprecated. "
1297 "Use scm_vector_writable_elements instead.");
1298 return SCM_I_VECTOR_WELTS (x
);
1302 scm_i_vector_ref (SCM x
, size_t idx
)
1304 scm_c_issue_deprecation_warning
1305 ("SCM_VECTOR_REF is deprecated. "
1306 "Use scm_c_vector_ref or scm_vector_elements instead.");
1307 return scm_c_vector_ref (x
, idx
);
1311 scm_i_vector_set (SCM x
, size_t idx
, SCM val
)
1313 scm_c_issue_deprecation_warning
1314 ("SCM_VECTOR_SET is deprecated. "
1315 "Use scm_c_vector_set_x or scm_vector_writable_elements instead.");
1316 scm_c_vector_set_x (x
, idx
, val
);
1320 scm_vector_equal_p (SCM x
, SCM y
)
1322 scm_c_issue_deprecation_warning
1323 ("scm_vector_euqal_p is deprecated. "
1324 "Use scm_equal_p instead.");
1325 return scm_equal_p (x
, y
);
1329 scm_i_arrayp (SCM a
)
1331 scm_c_issue_deprecation_warning
1332 ("SCM_ARRAYP is deprecated. Use scm_is_array instead.");
1333 return SCM_I_ARRAYP(a
);
1337 scm_i_array_ndim (SCM a
)
1339 scm_c_issue_deprecation_warning
1340 ("SCM_ARRAY_NDIM is deprecated. "
1341 "Use scm_c_array_rank or scm_array_handle_rank instead.");
1342 return scm_c_array_rank (a
);
1346 scm_i_array_contp (SCM a
)
1348 scm_c_issue_deprecation_warning
1349 ("SCM_ARRAY_CONTP is deprecated. Do not use it.");
1350 return SCM_I_ARRAY_CONTP (a
);
1354 scm_i_array_mem (SCM a
)
1356 scm_c_issue_deprecation_warning
1357 ("SCM_ARRAY_MEM is deprecated. Do not use it.");
1358 return (scm_t_array
*)SCM_I_ARRAY_MEM (a
);
1362 scm_i_array_v (SCM a
)
1364 /* We could use scm_shared_array_root here, but it is better to move
1365 them away from expecting vectors as the basic storage for arrays.
1367 scm_c_issue_deprecation_warning
1368 ("SCM_ARRAY_V is deprecated. Do not use it.");
1369 return SCM_I_ARRAY_V (a
);
1373 scm_i_array_base (SCM a
)
1375 scm_c_issue_deprecation_warning
1376 ("SCM_ARRAY_BASE is deprecated. Do not use it.");
1377 return SCM_I_ARRAY_BASE (a
);
1381 scm_i_array_dims (SCM a
)
1383 scm_c_issue_deprecation_warning
1384 ("SCM_ARRAY_DIMS is deprecated. Use scm_array_handle_dims instead.");
1385 return SCM_I_ARRAY_DIMS (a
);
1389 scm_i_cur_inp (void)
1391 scm_c_issue_deprecation_warning
1392 ("scm_cur_inp is deprecated. Use scm_current_input_port instead.");
1393 return scm_current_input_port ();
1397 scm_i_cur_outp (void)
1399 scm_c_issue_deprecation_warning
1400 ("scm_cur_outp is deprecated. Use scm_current_output_port instead.");
1401 return scm_current_output_port ();
1405 scm_i_cur_errp (void)
1407 scm_c_issue_deprecation_warning
1408 ("scm_cur_errp is deprecated. Use scm_current_error_port instead.");
1409 return scm_current_error_port ();
1413 scm_i_cur_loadp (void)
1415 scm_c_issue_deprecation_warning
1416 ("scm_cur_loadp is deprecated. Use scm_current_load_port instead.");
1417 return scm_current_load_port ();
1421 scm_i_progargs (void)
1423 scm_c_issue_deprecation_warning
1424 ("scm_progargs is deprecated. Use scm_program_arguments instead.");
1425 return scm_program_arguments ();
1429 scm_i_deprecated_dynwinds (void)
1431 scm_c_issue_deprecation_warning
1432 ("scm_dynwinds is deprecated. Do not use it.");
1433 return scm_i_dynwinds ();
1437 scm_i_deprecated_last_debug_frame (void)
1439 scm_c_issue_deprecation_warning
1440 ("scm_last_debug_frame is deprecated. Do not use it.");
1441 return scm_i_last_debug_frame ();
1445 scm_i_stack_base (void)
1447 scm_c_issue_deprecation_warning
1448 ("scm_stack_base is deprecated. Do not use it.");
1449 return SCM_I_CURRENT_THREAD
->base
;
1453 scm_i_fluidp (SCM x
)
1455 scm_c_issue_deprecation_warning
1456 ("SCM_FLUIDP is deprecated. Use scm_is_fluid instead.");
1457 return scm_is_fluid (x
);
1461 scm_i_defer_ints_etc ()
1463 scm_c_issue_deprecation_warning
1464 ("SCM_DEFER_INTS etc are deprecated. "
1465 "Use a mutex instead if appropriate.");
1469 scm_guard (SCM guardian
, SCM obj
, int throw_p
)
1471 scm_c_issue_deprecation_warning
1472 ("scm_guard is deprecated. Use scm_call_1 instead.");
1474 return scm_call_1 (guardian
, obj
);
1478 scm_get_one_zombie (SCM guardian
)
1480 scm_c_issue_deprecation_warning
1481 ("scm_guard is deprecated. Use scm_call_0 instead.");
1483 return scm_call_0 (guardian
);
1486 SCM_DEFINE (scm_guardian_destroyed_p
, "guardian-destroyed?", 1, 0, 0,
1488 "Return @code{#t} if @var{guardian} has been destroyed, otherwise @code{#f}.")
1489 #define FUNC_NAME s_scm_guardian_destroyed_p
1491 scm_c_issue_deprecation_warning
1492 ("'guardian-destroyed?' is deprecated.");
1497 SCM_DEFINE (scm_guardian_greedy_p
, "guardian-greedy?", 1, 0, 0,
1499 "Return @code{#t} if @var{guardian} is a greedy guardian, otherwise @code{#f}.")
1500 #define FUNC_NAME s_scm_guardian_greedy_p
1502 scm_c_issue_deprecation_warning
1503 ("'guardian-greedy?' is deprecated.");
1508 SCM_DEFINE (scm_destroy_guardian_x
, "destroy-guardian!", 1, 0, 0,
1510 "Destroys @var{guardian}, by making it impossible to put any more\n"
1511 "objects in it or get any objects from it. It also unguards any\n"
1512 "objects guarded by @var{guardian}.")
1513 #define FUNC_NAME s_scm_destroy_guardian_x
1515 scm_c_issue_deprecation_warning
1516 ("'destroy-guardian!' is deprecated and ineffective.");
1517 return SCM_UNSPECIFIED
;
1522 /* GC-related things. */
1524 unsigned long scm_mallocated
, scm_mtrigger
;
1525 size_t scm_max_segment_size
;
1527 #if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST)
1529 scm_map_free_list (void)
1535 #if defined (GUILE_DEBUG_FREELIST)
1537 scm_gc_set_debug_check_freelist_x (SCM flag
)
1539 return SCM_UNSPECIFIED
;
1545 scm_i_init_deprecated ()
1547 #include "libguile/deprecated.x"