deprecate something, move it here when that is feasible.
*/
-/* Copyright (C) 2003, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
# include <config.h>
#endif
+#include <math.h>
+#include <stdio.h>
+#include <string.h>
+
+#include <arpa/inet.h>
+
#define SCM_BUILDING_DEPRECATED_CODE
#include "libguile/_scm.h"
#include "libguile/async.h"
+#include "libguile/arrays.h"
+#include "libguile/array-map.h"
+#include "libguile/generalized-arrays.h"
+#include "libguile/bytevectors.h"
+#include "libguile/bitvectors.h"
#include "libguile/deprecated.h"
-#include "libguile/discouraged.h"
#include "libguile/deprecation.h"
#include "libguile/snarf.h"
#include "libguile/validate.h"
#include "libguile/strings.h"
#include "libguile/srfi-13.h"
#include "libguile/modules.h"
-#include "libguile/generalized-arrays.h"
#include "libguile/eval.h"
#include "libguile/smob.h"
#include "libguile/procprop.h"
#include "libguile/ports.h"
#include "libguile/eq.h"
#include "libguile/read.h"
+#include "libguile/r6rs-ports.h"
#include "libguile/strports.h"
#include "libguile/smob.h"
#include "libguile/alist.h"
#include "libguile/keywords.h"
#include "libguile/socket.h"
#include "libguile/feature.h"
+#include "libguile/uniform.h"
-#include <stdio.h>
-#include <string.h>
-
-#include <arpa/inet.h>
#if (SCM_ENABLE_DEPRECATED == 1)
static void
init_module_stuff ()
{
-#define PERM(x) scm_permanent_object(x)
-
- if (module_prefix == SCM_BOOL_F)
+ if (scm_is_false (module_prefix))
{
- module_prefix = PERM (scm_list_2 (scm_sym_app, scm_sym_modules));
- make_modules_in_var = PERM (scm_c_lookup ("make-modules-in"));
+ module_prefix = scm_list_2 (scm_sym_app, scm_sym_modules);
+ make_modules_in_var = scm_c_lookup ("make-modules-in");
beautify_user_module_x_var =
- PERM (scm_c_lookup ("beautify-user-module!"));
- try_module_autoload_var = PERM (scm_c_lookup ("try-module-autoload"));
+ scm_c_lookup ("beautify-user-module!");
+ try_module_autoload_var = scm_c_lookup ("try-module-autoload");
}
}
static void
maybe_close_port (void *data, SCM port)
{
- SCM except_set = (SCM) data;
+ SCM except_set = PTR2SCM (data);
while (!scm_is_null (except_set))
{
{
SCM p;
SCM_VALIDATE_REST_ARGUMENT (ports);
-
+
for (p = ports; !scm_is_null (p); p = SCM_CDR (p))
SCM_VALIDATE_OPPORT (SCM_ARG1, SCM_COERCE_OUTPORT (SCM_CAR (p)));
- scm_c_port_for_each (maybe_close_port, ports);
+ scm_c_port_for_each (maybe_close_port, SCM2PTR (ports));
return SCM_UNSPECIFIED;
}
{
SCM hook = scm_make_hook (scm_from_int (n_args));
scm_c_define (name, hook);
- return scm_permanent_object (hook);
+ return hook;
}
}
}
#undef FUNC_NAME
-SCM
-scm_make_subr_opt (const char *name, int type, SCM (*fcn) (), int set)
-{
- scm_c_issue_deprecation_warning
- ("`scm_make_subr_opt' is deprecated. Use `scm_c_make_subr' or "
- "`scm_c_define_subr' instead.");
-
- if (set)
- return scm_c_define_subr (name, type, fcn);
- else
- return scm_c_make_subr (name, type, fcn);
-}
-
-SCM
-scm_make_subr (const char *name, int type, SCM (*fcn) ())
-{
- scm_c_issue_deprecation_warning
- ("`scm_make_subr' is deprecated. Use `scm_c_define_subr' instead.");
-
- return scm_c_define_subr (name, type, fcn);
-}
-
-SCM
-scm_make_subr_with_generic (const char *name, int type, SCM (*fcn) (), SCM *gf)
-{
- scm_c_issue_deprecation_warning
- ("`scm_make_subr_with_generic' is deprecated. Use "
- "`scm_c_define_subr_with_generic' instead.");
-
- return scm_c_define_subr_with_generic (name, type, fcn, gf);
-}
-
/* Call thunk(closure) underneath a top-level error handler.
* If an error occurs, pass the exitval through err_filter and return it.
* If no error occurs, return the value of thunk.
"It is no longer needed.");
if (scm_smobs[n].size > 0)
- scm_gc_free ((void *) SCM_CELL_WORD_1 (obj),
+ scm_gc_free ((void *) SCM_SMOB_DATA_1 (obj),
scm_smobs[n].size, SCM_SMOBNAME (n));
return 0;
}
return scm_c_round (x);
}
+SCM
+scm_sys_expt (SCM x, SCM y)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_sys_expt is deprecated. Use scm_expt instead.");
+ return scm_expt (x, y);
+}
+
+double
+scm_asinh (double x)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_asinh is deprecated. Use asinh instead.");
+#if HAVE_ASINH
+ return asinh (x);
+#else
+ return log (x + sqrt (x * x + 1));
+#endif
+}
+
+double
+scm_acosh (double x)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_acosh is deprecated. Use acosh instead.");
+#if HAVE_ACOSH
+ return acosh (x);
+#else
+ return log (x + sqrt (x * x - 1));
+#endif
+}
+
+double
+scm_atanh (double x)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_atanh is deprecated. Use atanh instead.");
+#if HAVE_ATANH
+ return atanh (x);
+#else
+ return 0.5 * log ((1 + x) / (1 - x));
+#endif
+}
+
+SCM
+scm_sys_atan2 (SCM z1, SCM z2)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_sys_atan2 is deprecated. Use scm_atan instead.");
+ return scm_atan (z1, z2);
+}
+
char *
scm_i_deprecated_symbol_chars (SCM sym)
{
return scm_equal_p (x, y);
}
-int
-scm_i_arrayp (SCM a)
-{
- scm_c_issue_deprecation_warning
- ("SCM_ARRAYP is deprecated. Use scm_is_array instead.");
- return SCM_I_ARRAYP(a);
-}
+SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0,
+ (SCM uvec, SCM port_or_fd, SCM start, SCM end),
+ "Fill the elements of @var{uvec} by reading\n"
+ "raw bytes from @var{port-or-fdes}, using host byte order.\n\n"
+ "The optional arguments @var{start} (inclusive) and @var{end}\n"
+ "(exclusive) allow a specified region to be read,\n"
+ "leaving the remainder of the vector unchanged.\n\n"
+ "When @var{port-or-fdes} is a port, all specified elements\n"
+ "of @var{uvec} are attempted to be read, potentially blocking\n"
+ "while waiting for more input or end-of-file.\n"
+ "When @var{port-or-fd} is an integer, a single call to\n"
+ "read(2) is made.\n\n"
+ "An error is signalled when the last element has only\n"
+ "been partially filled before reaching end-of-file or in\n"
+ "the single call to read(2).\n\n"
+ "@code{uniform-vector-read!} returns the number of elements\n"
+ "read.\n\n"
+ "@var{port-or-fdes} may be omitted, in which case it defaults\n"
+ "to the value returned by @code{(current-input-port)}.")
+#define FUNC_NAME s_scm_uniform_vector_read_x
+{
+ SCM result;
+ size_t c_width, c_start, c_end;
+
+ SCM_VALIDATE_BYTEVECTOR (SCM_ARG1, uvec);
-size_t
-scm_i_array_ndim (SCM a)
-{
scm_c_issue_deprecation_warning
- ("SCM_ARRAY_NDIM is deprecated. "
- "Use scm_c_array_rank or scm_array_handle_rank instead.");
- return scm_c_array_rank (a);
-}
+ ("`uniform-vector-read!' is deprecated. Use `get-bytevector-n!' from\n"
+ "`(rnrs io ports)' instead.");
-int
-scm_i_array_contp (SCM a)
-{
- scm_c_issue_deprecation_warning
- ("SCM_ARRAY_CONTP is deprecated. Do not use it.");
- return SCM_I_ARRAY_CONTP (a);
-}
+ if (SCM_UNBNDP (port_or_fd))
+ port_or_fd = scm_current_input_port ();
-scm_t_array *
-scm_i_array_mem (SCM a)
-{
- scm_c_issue_deprecation_warning
- ("SCM_ARRAY_MEM is deprecated. Do not use it.");
- return (scm_t_array *)SCM_I_ARRAY_MEM (a);
+ c_width = scm_to_size_t (scm_uniform_vector_element_size (uvec));
+
+ c_start = SCM_UNBNDP (start) ? 0 : scm_to_size_t (start);
+ c_start *= c_width;
+
+ c_end = SCM_UNBNDP (end) ? SCM_BYTEVECTOR_LENGTH (uvec)
+ : scm_to_size_t (end) * c_width;
+
+ result = scm_get_bytevector_n_x (port_or_fd, uvec,
+ scm_from_size_t (c_start),
+ scm_from_size_t (c_end - c_start));
+
+ if (SCM_EOF_OBJECT_P (result))
+ result = SCM_INUM0;
+
+ return result;
}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0,
+ (SCM uvec, SCM port_or_fd, SCM start, SCM end),
+ "Write the elements of @var{uvec} as raw bytes to\n"
+ "@var{port-or-fdes}, in the host byte order.\n\n"
+ "The optional arguments @var{start} (inclusive)\n"
+ "and @var{end} (exclusive) allow\n"
+ "a specified region to be written.\n\n"
+ "When @var{port-or-fdes} is a port, all specified elements\n"
+ "of @var{uvec} are attempted to be written, potentially blocking\n"
+ "while waiting for more room.\n"
+ "When @var{port-or-fd} is an integer, a single call to\n"
+ "write(2) is made.\n\n"
+ "An error is signalled when the last element has only\n"
+ "been partially written in the single call to write(2).\n\n"
+ "The number of objects actually written is returned.\n"
+ "@var{port-or-fdes} may be\n"
+ "omitted, in which case it defaults to the value returned by\n"
+ "@code{(current-output-port)}.")
+#define FUNC_NAME s_scm_uniform_vector_write
+{
+ size_t c_width, c_start, c_end;
+
+ SCM_VALIDATE_BYTEVECTOR (SCM_ARG1, uvec);
-SCM
-scm_i_array_v (SCM a)
-{
- /* We could use scm_shared_array_root here, but it is better to move
- them away from expecting vectors as the basic storage for arrays.
- */
scm_c_issue_deprecation_warning
- ("SCM_ARRAY_V is deprecated. Do not use it.");
- return SCM_I_ARRAY_V (a);
+ ("`uniform-vector-write' is deprecated. Use `put-bytevector' from\n"
+ "`(rnrs io ports)' instead.");
+
+ if (SCM_UNBNDP (port_or_fd))
+ port_or_fd = scm_current_output_port ();
+
+ port_or_fd = SCM_COERCE_OUTPORT (port_or_fd);
+
+ c_width = scm_to_size_t (scm_uniform_vector_element_size (uvec));
+
+ c_start = SCM_UNBNDP (start) ? 0 : scm_to_size_t (start);
+ c_start *= c_width;
+
+ c_end = SCM_UNBNDP (end) ? SCM_BYTEVECTOR_LENGTH (uvec) : scm_to_size_t (end);
+ c_end *= c_width;
+
+ return scm_put_bytevector (port_or_fd, uvec,
+ scm_from_size_t (c_start),
+ scm_from_size_t (c_end - c_start));
}
+#undef FUNC_NAME
-size_t
-scm_i_array_base (SCM a)
-{
- scm_c_issue_deprecation_warning
- ("SCM_ARRAY_BASE is deprecated. Do not use it.");
- return SCM_I_ARRAY_BASE (a);
+static SCM
+scm_ra2contig (SCM ra, int copy)
+{
+ SCM ret;
+ long inc = 1;
+ size_t k, len = 1;
+ for (k = SCM_I_ARRAY_NDIM (ra); k--;)
+ len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
+ k = SCM_I_ARRAY_NDIM (ra);
+ if (SCM_I_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_I_ARRAY_DIMS (ra)[k - 1].inc)))
+ {
+ if (!scm_is_bitvector (SCM_I_ARRAY_V (ra)))
+ return ra;
+ if ((len == scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) &&
+ 0 == SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT &&
+ 0 == len % SCM_LONG_BIT))
+ return ra;
+ }
+ ret = scm_i_make_array (k);
+ SCM_I_ARRAY_BASE (ret) = 0;
+ while (k--)
+ {
+ SCM_I_ARRAY_DIMS (ret)[k].lbnd = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
+ SCM_I_ARRAY_DIMS (ret)[k].ubnd = SCM_I_ARRAY_DIMS (ra)[k].ubnd;
+ SCM_I_ARRAY_DIMS (ret)[k].inc = inc;
+ inc *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
+ }
+ SCM_I_ARRAY_V (ret) =
+ scm_make_generalized_vector (scm_array_type (ra), scm_from_size_t (inc),
+ SCM_UNDEFINED);
+ if (copy)
+ scm_array_copy_x (ra, ret);
+ return ret;
+}
+
+SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0,
+ (SCM ura, SCM port_or_fd, SCM start, SCM end),
+ "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
+ "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
+ "binary objects from @var{port-or-fdes}.\n"
+ "If an end of file is encountered,\n"
+ "the objects up to that point are put into @var{ura}\n"
+ "(starting at the beginning) and the remainder of the array is\n"
+ "unchanged.\n\n"
+ "The optional arguments @var{start} and @var{end} allow\n"
+ "a specified region of a vector (or linearized array) to be read,\n"
+ "leaving the remainder of the vector unchanged.\n\n"
+ "@code{uniform-array-read!} returns the number of objects read.\n"
+ "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
+ "returned by @code{(current-input-port)}.")
+#define FUNC_NAME s_scm_uniform_array_read_x
+{
+ if (SCM_UNBNDP (port_or_fd))
+ port_or_fd = scm_current_input_port ();
+
+ if (scm_is_uniform_vector (ura))
+ {
+ return scm_uniform_vector_read_x (ura, port_or_fd, start, end);
+ }
+ else if (SCM_I_ARRAYP (ura))
+ {
+ size_t base, vlen, cstart, cend;
+ SCM cra, ans;
+
+ cra = scm_ra2contig (ura, 0);
+ base = SCM_I_ARRAY_BASE (cra);
+ vlen = SCM_I_ARRAY_DIMS (cra)->inc *
+ (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1);
+
+ cstart = 0;
+ cend = vlen;
+ if (!SCM_UNBNDP (start))
+ {
+ cstart = scm_to_unsigned_integer (start, 0, vlen);
+ if (!SCM_UNBNDP (end))
+ cend = scm_to_unsigned_integer (end, cstart, vlen);
+ }
+
+ ans = scm_uniform_vector_read_x (SCM_I_ARRAY_V (cra), port_or_fd,
+ scm_from_size_t (base + cstart),
+ scm_from_size_t (base + cend));
+
+ if (!scm_is_eq (cra, ura))
+ scm_array_copy_x (cra, ura);
+ return ans;
+ }
+ else
+ scm_wrong_type_arg_msg (NULL, 0, ura, "array");
}
+#undef FUNC_NAME
-scm_t_array_dim *
-scm_i_array_dims (SCM a)
-{
- scm_c_issue_deprecation_warning
- ("SCM_ARRAY_DIMS is deprecated. Use scm_array_handle_dims instead.");
- return SCM_I_ARRAY_DIMS (a);
+SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0,
+ (SCM ura, SCM port_or_fd, SCM start, SCM end),
+ "Writes all elements of @var{ura} as binary objects to\n"
+ "@var{port-or-fdes}.\n\n"
+ "The optional arguments @var{start}\n"
+ "and @var{end} allow\n"
+ "a specified region of a vector (or linearized array) to be written.\n\n"
+ "The number of objects actually written is returned.\n"
+ "@var{port-or-fdes} may be\n"
+ "omitted, in which case it defaults to the value returned by\n"
+ "@code{(current-output-port)}.")
+#define FUNC_NAME s_scm_uniform_array_write
+{
+ if (SCM_UNBNDP (port_or_fd))
+ port_or_fd = scm_current_output_port ();
+
+ if (scm_is_uniform_vector (ura))
+ {
+ return scm_uniform_vector_write (ura, port_or_fd, start, end);
+ }
+ else if (SCM_I_ARRAYP (ura))
+ {
+ size_t base, vlen, cstart, cend;
+ SCM cra, ans;
+
+ cra = scm_ra2contig (ura, 1);
+ base = SCM_I_ARRAY_BASE (cra);
+ vlen = SCM_I_ARRAY_DIMS (cra)->inc *
+ (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1);
+
+ cstart = 0;
+ cend = vlen;
+ if (!SCM_UNBNDP (start))
+ {
+ cstart = scm_to_unsigned_integer (start, 0, vlen);
+ if (!SCM_UNBNDP (end))
+ cend = scm_to_unsigned_integer (end, cstart, vlen);
+ }
+
+ ans = scm_uniform_vector_write (SCM_I_ARRAY_V (cra), port_or_fd,
+ scm_from_size_t (base + cstart),
+ scm_from_size_t (base + cend));
+
+ return ans;
+ }
+ else
+ scm_wrong_type_arg_msg (NULL, 0, ura, "array");
}
+#undef FUNC_NAME
SCM
scm_i_cur_inp (void)
return scm_i_dynwinds ();
}
-scm_t_debug_frame *
-scm_i_deprecated_last_debug_frame (void)
-{
- scm_c_issue_deprecation_warning
- ("scm_last_debug_frame is deprecated. Do not use it.");
- return scm_i_last_debug_frame ();
-}
-
SCM_STACKITEM *
scm_i_stack_base (void)
{
return scm_call_2;
}
+int
+scm_i_subr_p (SCM x)
+{
+ scm_c_issue_deprecation_warning ("`scm_subr_p' is deprecated. Use SCM_PRIMITIVE_P instead.");
+ return SCM_PRIMITIVE_P (x);
+}
+
\f
-void
-scm_i_init_deprecated ()
+
+SCM
+scm_internal_lazy_catch (SCM tag, scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void *handler_data)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_internal_lazy_catch' is no longer supported. Instead this call will\n"
+ "dispatch to `scm_c_with_throw_handler'. Your handler will be invoked from\n"
+ "within the dynamic context of the corresponding `throw'.\n"
+ "\nTHIS COULD CHANGE YOUR PROGRAM'S BEHAVIOR.\n\n"
+ "Please modify your program to use `scm_c_with_throw_handler' directly,\n"
+ "and adapt it (if necessary) to expect to be within the dynamic context\n"
+ "of the throw.");
+ return scm_c_with_throw_handler (tag, body, body_data, handler, handler_data, 0);
+}
+
+SCM_DEFINE (scm_lazy_catch, "lazy-catch", 3, 0, 0,
+ (SCM key, SCM thunk, SCM handler),
+ "This behaves exactly like @code{catch}, except that it does\n"
+ "not unwind the stack before invoking @var{handler}.\n"
+ "If the @var{handler} procedure returns normally, Guile\n"
+ "rethrows the same exception again to the next innermost catch,\n"
+ "lazy-catch or throw handler. If the @var{handler} exits\n"
+ "non-locally, that exit determines the continuation.")
+#define FUNC_NAME s_scm_lazy_catch
+{
+ struct scm_body_thunk_data c;
+
+ SCM_ASSERT (scm_is_symbol (key) || scm_is_eq (key, SCM_BOOL_T),
+ key, SCM_ARG1, FUNC_NAME);
+
+ c.tag = key;
+ c.body_proc = thunk;
+
+ scm_c_issue_deprecation_warning
+ ("`lazy-catch' is no longer supported. Instead this call will dispatch\n"
+ "to `with-throw-handler'. Your handler will be invoked from within the\n"
+ "dynamic context of the corresponding `throw'.\n"
+ "\nTHIS COULD CHANGE YOUR PROGRAM'S BEHAVIOR.\n\n"
+ "Please modify your program to use `with-throw-handler' directly, and\n"
+ "adapt it (if necessary) to expect to be within the dynamic context of\n"
+ "the throw.");
+
+ return scm_c_with_throw_handler (key,
+ scm_body_thunk, &c,
+ scm_handle_by_proc, &handler, 0);
+}
+#undef FUNC_NAME
+
+
+\f
+
+
+SCM
+scm_raequal (SCM ra0, SCM ra1)
+{
+ return scm_array_equal_p (ra0, ra1);
+}
+
+
+\f
+
+
+SCM_DEFINE (scm_dynamic_args_call, "dynamic-args-call", 3, 0, 0,
+ (SCM func, SCM dobj, SCM args),
+ "Call the C function indicated by @var{func} and @var{dobj},\n"
+ "just like @code{dynamic-call}, but pass it some arguments and\n"
+ "return its return value. The C function is expected to take\n"
+ "two arguments and return an @code{int}, just like @code{main}:\n"
+ "@smallexample\n"
+ "int c_func (int argc, char **argv);\n"
+ "@end smallexample\n\n"
+ "The parameter @var{args} must be a list of strings and is\n"
+ "converted into an array of @code{char *}. The array is passed\n"
+ "in @var{argv} and its size in @var{argc}. The return value is\n"
+ "converted to a Scheme number and returned from the call to\n"
+ "@code{dynamic-args-call}.")
+#define FUNC_NAME s_scm_dynamic_args_call
+{
+ int (*fptr) (int argc, char **argv);
+ int result, argc;
+ char **argv;
+
+ if (scm_is_string (func))
+ {
+#if HAVE_MODULES
+ func = scm_dynamic_func (func, dobj);
+#else
+ scm_misc_error ("dynamic-args-call",
+ "dynamic-func not available to resolve ~S",
+ scm_list_1 (func));
+#endif
+ }
+ SCM_VALIDATE_POINTER (SCM_ARG1, func);
+
+ fptr = SCM_POINTER_VALUE (func);
+
+ argv = scm_i_allocate_string_pointers (args);
+ for (argc = 0; argv[argc]; argc++)
+ ;
+ result = (*fptr) (argc, argv);
+
+ return scm_from_int (result);
+}
+#undef FUNC_NAME
+
+
+\f
+
+
+int
+scm_badargsp (SCM formals, SCM args)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_badargsp' is deprecated. Copy it into your project if you need it.");
+
+ while (!scm_is_null (formals))
+ {
+ if (!scm_is_pair (formals))
+ return 0;
+ if (scm_is_null (args))
+ return 1;
+ formals = scm_cdr (formals);
+ args = scm_cdr (args);
+ }
+ return !scm_is_null (args) ? 1 : 0;
+}
+
+\f
+
+/* scm_internal_stack_catch
+ Use this one if you want debugging information to be stored in
+ the-last-stack on error. */
+
+static SCM
+ss_handler (void *data SCM_UNUSED, SCM tag, SCM throw_args)
+{
+ /* In the stack */
+ scm_fluid_set_x (scm_variable_ref
+ (scm_c_module_lookup
+ (scm_c_resolve_module ("ice-9 save-stack"),
+ "the-last-stack")),
+ scm_make_stack (SCM_BOOL_T, SCM_EOL));
+ /* Throw the error */
+ return scm_throw (tag, throw_args);
+}
+
+struct cwss_data
+{
+ SCM tag;
+ scm_t_catch_body body;
+ void *data;
+};
+
+static SCM
+cwss_body (void *data)
+{
+ struct cwss_data *d = data;
+ return scm_c_with_throw_handler (d->tag, d->body, d->data, ss_handler, NULL, 0);
+}
+
+SCM
+scm_internal_stack_catch (SCM tag,
+ scm_t_catch_body body,
+ void *body_data,
+ scm_t_catch_handler handler,
+ void *handler_data)
+{
+ struct cwss_data d;
+ d.tag = tag;
+ d.body = body;
+ d.data = body_data;
+ scm_c_issue_deprecation_warning
+ ("`scm_internal_stack_catch' is deprecated. Talk to guile-devel if you see this message.");
+ return scm_internal_catch (tag, cwss_body, &d, handler, handler_data);
+}
+
+\f
+
+SCM
+scm_short2num (short x)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_short2num' is deprecated. Use scm_from_short instead.");
+ return scm_from_short (x);
+}
+
+SCM
+scm_ushort2num (unsigned short x)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_ushort2num' is deprecated. Use scm_from_ushort instead.");
+ return scm_from_ushort (x);
+}
+
+SCM
+scm_int2num (int x)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_int2num' is deprecated. Use scm_from_int instead.");
+ return scm_from_int (x);
+}
+
+SCM
+scm_uint2num (unsigned int x)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_uint2num' is deprecated. Use scm_from_uint instead.");
+ return scm_from_uint (x);
+}
+
+SCM
+scm_long2num (long x)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_long2num' is deprecated. Use scm_from_long instead.");
+ return scm_from_long (x);
+}
+
+SCM
+scm_ulong2num (unsigned long x)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_ulong2num' is deprecated. Use scm_from_ulong instead.");
+ return scm_from_ulong (x);
+}
+
+SCM
+scm_size2num (size_t x)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_size2num' is deprecated. Use scm_from_size_t instead.");
+ return scm_from_size_t (x);
+}
+
+SCM
+scm_ptrdiff2num (ptrdiff_t x)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_ptrdiff2num' is deprecated. Use scm_from_ssize_t instead.");
+ return scm_from_ssize_t (x);
+}
+
+short
+scm_num2short (SCM x, unsigned long pos, const char *s_caller)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_num2short' is deprecated. Use scm_to_short instead.");
+ return scm_to_short (x);
+}
+
+unsigned short
+scm_num2ushort (SCM x, unsigned long pos, const char *s_caller)
{
+ scm_c_issue_deprecation_warning
+ ("`scm_num2ushort' is deprecated. Use scm_to_ushort instead.");
+ return scm_to_ushort (x);
+}
+
+int
+scm_num2int (SCM x, unsigned long pos, const char *s_caller)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_num2int' is deprecated. Use scm_to_int instead.");
+ return scm_to_int (x);
+}
+
+unsigned int
+scm_num2uint (SCM x, unsigned long pos, const char *s_caller)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_num2uint' is deprecated. Use scm_to_uint instead.");
+ return scm_to_uint (x);
+}
+
+long
+scm_num2long (SCM x, unsigned long pos, const char *s_caller)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_num2long' is deprecated. Use scm_to_long instead.");
+ return scm_to_long (x);
+}
+
+unsigned long
+scm_num2ulong (SCM x, unsigned long pos, const char *s_caller)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_num2ulong' is deprecated. Use scm_to_ulong instead.");
+ return scm_to_ulong (x);
+}
+
+size_t
+scm_num2size (SCM x, unsigned long pos, const char *s_caller)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_num2size' is deprecated. Use scm_to_size_t instead.");
+ return scm_to_size_t (x);
+}
+
+ptrdiff_t
+scm_num2ptrdiff (SCM x, unsigned long pos, const char *s_caller)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_num2ptrdiff' is deprecated. Use scm_to_ssize_t instead.");
+ return scm_to_ssize_t (x);
+}
+
+#if SCM_SIZEOF_LONG_LONG != 0
+
+SCM
+scm_long_long2num (long long x)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_long_long2num' is deprecated. Use scm_from_long_long instead.");
+ return scm_from_long_long (x);
+}
+
+SCM
+scm_ulong_long2num (unsigned long long x)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_ulong_long2num' is deprecated. Use scm_from_ulong_long instead.");
+ return scm_from_ulong_long (x);
+}
+
+long long
+scm_num2long_long (SCM x, unsigned long pos, const char *s_caller)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_num2long_long' is deprecated. Use scm_to_long_long instead.");
+ return scm_to_long_long (x);
+}
+
+unsigned long long
+scm_num2ulong_long (SCM x, unsigned long pos, const char *s_caller)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_num2ulong_long' is deprecated. Use scm_from_ulong_long instead.");
+ return scm_to_ulong_long (x);
+}
+
+#endif
+
+SCM
+scm_make_real (double x)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_make_real' is deprecated. Use scm_from_double instead.");
+ return scm_from_double (x);
+}
+
+double
+scm_num2dbl (SCM a, const char *why)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_num2dbl' is deprecated. Use scm_to_double instead.");
+ return scm_to_double (a);
+}
+
+SCM
+scm_float2num (float n)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_float2num' is deprecated. Use scm_from_double instead.");
+ return scm_from_double ((double) n);
+}
+
+SCM
+scm_double2num (double n)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_double2num' is deprecated. Use scm_from_double instead.");
+ return scm_from_double (n);
+}
+
+SCM
+scm_make_complex (double x, double y)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_make_complex' is deprecated. Use scm_c_make_rectangular instead.");
+ return scm_c_make_rectangular (x, y);
+}
+
+SCM
+scm_mem2symbol (const char *mem, size_t len)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_mem2symbol' is deprecated. Use scm_from_locale_symboln instead.");
+ return scm_from_locale_symboln (mem, len);
+}
+
+SCM
+scm_mem2uninterned_symbol (const char *mem, size_t len)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_mem2uninterned_symbol' is deprecated. "
+ "Use scm_make_symbol and scm_from_locale_symboln instead.");
+ return scm_make_symbol (scm_from_locale_stringn (mem, len));
+}
+
+SCM
+scm_str2symbol (const char *str)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_str2symbol' is deprecated. Use scm_from_locale_symbol instead.");
+ return scm_from_locale_symbol (str);
+}
+
+
+/* This function must only be applied to memory obtained via malloc,
+ since the GC is going to apply `free' to it when the string is
+ dropped.
+
+ Also, s[len] must be `\0', since we promise that strings are
+ null-terminated. Perhaps we could handle non-null-terminated
+ strings by claiming they're shared substrings of a string we just
+ made up. */
+SCM
+scm_take_str (char *s, size_t len)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_take_str' is deprecated. Use scm_take_locale_stringn instead.");
+ return scm_take_locale_stringn (s, len);
+}
+
+/* `s' must be a malloc'd string. See scm_take_str. */
+SCM
+scm_take0str (char *s)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_take0str' is deprecated. Use scm_take_locale_string instead.");
+ return scm_take_locale_string (s);
+}
+
+SCM
+scm_mem2string (const char *src, size_t len)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_mem2string' is deprecated. Use scm_from_locale_stringn instead.");
+ return scm_from_locale_stringn (src, len);
+}
+
+SCM
+scm_str2string (const char *src)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_str2string' is deprecated. Use scm_from_locale_string instead.");
+ return scm_from_locale_string (src);
+}
+
+SCM
+scm_makfrom0str (const char *src)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_makfrom0str' is deprecated."
+ "Use scm_from_locale_string instead, but check for NULL first.");
+ if (!src) return SCM_BOOL_F;
+ return scm_from_locale_string (src);
+}
+
+SCM
+scm_makfrom0str_opt (const char *src)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_makfrom0str_opt' is deprecated."
+ "Use scm_from_locale_string instead, but check for NULL first.");
+ return scm_makfrom0str (src);
+}
+
+
+SCM
+scm_allocate_string (size_t len)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_allocate_string' is deprecated. Use scm_c_make_string instead.");
+ return scm_i_make_string (len, NULL, 0);
+}
+
+SCM_DEFINE (scm_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", 1, 0, 0,
+ (SCM symbol),
+ "Make a keyword object from a @var{symbol} that starts with a dash.")
+#define FUNC_NAME s_scm_make_keyword_from_dash_symbol
+{
+ SCM dash_string, non_dash_symbol;
+
+ scm_c_issue_deprecation_warning
+ ("`scm_make_keyword_from_dash_symbol' is deprecated. Don't use dash symbols.");
+
+ SCM_ASSERT (scm_is_symbol (symbol)
+ && (scm_i_symbol_ref (symbol, 0) == '-'),
+ symbol, SCM_ARG1, FUNC_NAME);
+
+ dash_string = scm_symbol_to_string (symbol);
+ non_dash_symbol =
+ scm_string_to_symbol (scm_c_substring (dash_string,
+ 1,
+ scm_c_string_length (dash_string)));
+
+ return scm_symbol_to_keyword (non_dash_symbol);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_keyword_dash_symbol, "keyword-dash-symbol", 1, 0, 0,
+ (SCM keyword),
+ "Return the dash symbol for @var{keyword}.\n"
+ "This is the inverse of @code{make-keyword-from-dash-symbol}.")
+#define FUNC_NAME s_scm_keyword_dash_symbol
+{
+ SCM symbol = scm_keyword_to_symbol (keyword);
+ SCM parts = scm_list_2 (scm_from_locale_string ("-"),
+ scm_symbol_to_string (symbol));
+ scm_c_issue_deprecation_warning
+ ("`scm_keyword_dash_symbol' is deprecated. Don't use dash symbols.");
+
+ return scm_string_to_symbol (scm_string_append (parts));
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_make_keyword (const char *s)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_c_make_keyword' is deprecated. Use scm_from_locale_keyword instead.");
+ return scm_from_locale_keyword (s);
+}
+
+unsigned int
+scm_thread_sleep (unsigned int t)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_thread_sleep' is deprecated. Use scm_std_sleep instead.");
+ return scm_std_sleep (t);
+}
+
+unsigned long
+scm_thread_usleep (unsigned long t)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_thread_usleep' is deprecated. Use scm_std_usleep instead.");
+ return scm_std_usleep (t);
+}
+
+#ifdef HAVE_SYS_SELECT_H
+int scm_internal_select (int fds,
+ fd_set *rfds,
+ fd_set *wfds,
+ fd_set *efds,
+ struct timeval *timeout)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_internal_select' is deprecated. Use scm_std_select instead.");
+ return scm_std_select (fds, rfds, wfds, efds, timeout);
+}
+#endif /* HAVE_SYS_SELECT_H */
+
+\f
+
+#ifdef HAVE_CUSERID
+
+# if !HAVE_DECL_CUSERID
+extern char *cuserid (char *);
+# endif
+
+SCM_DEFINE (scm_cuserid, "cuserid", 0, 0, 0,
+ (void),
+ "Return a string containing a user name associated with the\n"
+ "effective user id of the process. Return @code{#f} if this\n"
+ "information cannot be obtained.")
+#define FUNC_NAME s_scm_cuserid
+{
+ char buf[L_cuserid];
+ char * p;
+
+ scm_c_issue_deprecation_warning
+ ("`cuserid' is deprecated. Use `(passwd:name (getpwuid (geteuid)))' instead.");
+
+ p = cuserid (buf);
+ if (!p || !*p)
+ return SCM_BOOL_F;
+ return scm_from_locale_string (p);
+}
+#undef FUNC_NAME
+#endif /* HAVE_CUSERID */
+
+\f
+
+/* {Properties}
+ */
+
+static SCM properties_whash;
+
+SCM_DEFINE (scm_primitive_make_property, "primitive-make-property", 1, 0, 0,
+ (SCM not_found_proc),
+ "Create a @dfn{property token} that can be used with\n"
+ "@code{primitive-property-ref} and @code{primitive-property-set!}.\n"
+ "See @code{primitive-property-ref} for the significance of\n"
+ "@var{not_found_proc}.")
+#define FUNC_NAME s_scm_primitive_make_property
+{
+ scm_c_issue_deprecation_warning
+ ("`primitive-make-property' is deprecated. Use object properties.");
+
+ if (!scm_is_false (not_found_proc))
+ SCM_VALIDATE_PROC (SCM_ARG1, not_found_proc);
+ return scm_cons (not_found_proc, SCM_EOL);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_primitive_property_ref, "primitive-property-ref", 2, 0, 0,
+ (SCM prop, SCM obj),
+ "Return the property @var{prop} of @var{obj}.\n"
+ "\n"
+ "When no value has yet been associated with @var{prop} and\n"
+ "@var{obj}, the @var{not-found-proc} from @var{prop} is used. A\n"
+ "call @code{(@var{not-found-proc} @var{prop} @var{obj})} is made\n"
+ "and the result set as the property value. If\n"
+ "@var{not-found-proc} is @code{#f} then @code{#f} is the\n"
+ "property value.")
+#define FUNC_NAME s_scm_primitive_property_ref
+{
+ SCM alist;
+
+ scm_c_issue_deprecation_warning
+ ("`primitive-property-ref' is deprecated. Use object properties.");
+
+ SCM_VALIDATE_CONS (SCM_ARG1, prop);
+
+ alist = scm_hashq_ref (properties_whash, obj, SCM_EOL);
+ if (scm_is_pair (alist))
+ {
+ SCM assoc = scm_assq (prop, alist);
+ if (scm_is_true (assoc))
+ return SCM_CDR (assoc);
+ }
+
+ if (scm_is_false (SCM_CAR (prop)))
+ return SCM_BOOL_F;
+ else
+ {
+ SCM val = scm_call_2 (SCM_CAR (prop), prop, obj);
+ scm_hashq_set_x (properties_whash, obj,
+ scm_acons (prop, val, alist));
+ return val;
+ }
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_primitive_property_set_x, "primitive-property-set!", 3, 0, 0,
+ (SCM prop, SCM obj, SCM val),
+ "Set the property @var{prop} of @var{obj} to @var{val}.")
+#define FUNC_NAME s_scm_primitive_property_set_x
+{
+ SCM alist, assoc;
+
+ scm_c_issue_deprecation_warning
+ ("`primitive-property-set!' is deprecated. Use object properties.");
+
+ SCM_VALIDATE_CONS (SCM_ARG1, prop);
+ alist = scm_hashq_ref (properties_whash, obj, SCM_EOL);
+ assoc = scm_assq (prop, alist);
+ if (scm_is_pair (assoc))
+ SCM_SETCDR (assoc, val);
+ else
+ scm_hashq_set_x (properties_whash, obj,
+ scm_acons (prop, val, alist));
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_primitive_property_del_x, "primitive-property-del!", 2, 0, 0,
+ (SCM prop, SCM obj),
+ "Remove any value associated with @var{prop} and @var{obj}.")
+#define FUNC_NAME s_scm_primitive_property_del_x
+{
+ SCM alist;
+
+ scm_c_issue_deprecation_warning
+ ("`primitive-property-del!' is deprecated. Use object properties.");
+
+ SCM_VALIDATE_CONS (SCM_ARG1, prop);
+ alist = scm_hashq_ref (properties_whash, obj, SCM_EOL);
+ if (scm_is_pair (alist))
+ scm_hashq_set_x (properties_whash, obj, scm_assq_remove_x (alist, prop));
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+\f
+
+SCM
+scm_whash_get_handle (SCM whash, SCM key)
+{
+ scm_c_issue_deprecation_warning
+ ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
+
+ return scm_hashq_get_handle (whash, key);
+}
+
+int
+SCM_WHASHFOUNDP (SCM h)
+{
+ scm_c_issue_deprecation_warning
+ ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
+
+ return scm_is_true (h);
+}
+
+SCM
+SCM_WHASHREF (SCM whash, SCM handle)
+{
+ scm_c_issue_deprecation_warning
+ ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
+
+ return SCM_CDR (handle);
+}
+
+void
+SCM_WHASHSET (SCM whash, SCM handle, SCM obj)
+{
+ scm_c_issue_deprecation_warning
+ ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
+
+ SCM_SETCDR (handle, obj);
+}
+
+SCM
+scm_whash_create_handle (SCM whash, SCM key)
+{
+ scm_c_issue_deprecation_warning
+ ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
+
+ return scm_hashq_create_handle_x (whash, key, SCM_UNSPECIFIED);
+}
+
+SCM
+scm_whash_lookup (SCM whash, SCM obj)
+{
+ scm_c_issue_deprecation_warning
+ ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
+
+ return scm_hashq_ref (whash, obj, SCM_BOOL_F);
+}
+
+void
+scm_whash_insert (SCM whash, SCM key, SCM obj)
+{
+ scm_c_issue_deprecation_warning
+ ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
+
+ scm_hashq_set_x (whash, key, obj);
+}
+
+\f
+
+SCM scm_struct_table = SCM_BOOL_F;
+
+SCM
+scm_struct_create_handle (SCM obj)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_struct_create_handle' is deprecated, and has no effect.");
+
+ return scm_cons (obj, scm_cons (SCM_BOOL_F, SCM_BOOL_F));
+}
+
+\f
+
+SCM
+scm_internal_dynamic_wind (scm_t_guard before,
+ scm_t_inner inner,
+ scm_t_guard after,
+ void *inner_data,
+ void *guard_data)
+{
+ SCM ans;
+
+ scm_c_issue_deprecation_warning
+ ("`scm_internal_dynamic_wind' is deprecated. "
+ "Use the `scm_dynwind_begin' / `scm_dynwind_end' API instead.");
+
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ scm_dynwind_rewind_handler (before, guard_data, SCM_F_WIND_EXPLICITLY);
+ scm_dynwind_unwind_handler (after, guard_data, SCM_F_WIND_EXPLICITLY);
+ ans = inner (inner_data);
+ scm_dynwind_end ();
+ return ans;
+}
+
+\f
+
+SCM
+scm_immutable_cell (scm_t_bits car, scm_t_bits cdr)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_immutable_cell is deprecated. Use scm_cell instead.");
+
+ return scm_cell (car, cdr);
+}
+
+SCM
+scm_immutable_double_cell (scm_t_bits car, scm_t_bits cbr,
+ scm_t_bits ccr, scm_t_bits cdr)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_immutable_double_cell is deprecated. Use scm_double_cell instead.");
+
+ return scm_double_cell (car, cbr, ccr, cdr);
+}
+
+\f
+
+
+scm_t_bits
+scm_i_deprecated_asrtgo (scm_t_bits condition)
+{
+ scm_c_issue_deprecation_warning
+ ("SCM_ASRTGO is deprecated. Use `if (!condition) goto label;' directly.");
+
+ return condition;
+}
+
+
+\f
+
+
+/* scm_sym2var
+ *
+ * looks up the variable bound to SYM according to PROC. PROC should be
+ * a `eval closure' of some module.
+ *
+ * When no binding exists, and DEFINEP is true, create a new binding
+ * with a initial value of SCM_UNDEFINED. Return `#f' when DEFINEP as
+ * false and no binding exists.
+ *
+ * When PROC is `#f', it is ignored and the binding is searched for in
+ * the scm_pre_modules_obarray (a `eq' hash table).
+ */
+
+SCM
+scm_sym2var (SCM sym, SCM proc, SCM definep)
+#define FUNC_NAME "scm_sym2var"
+{
+ SCM var;
+
+ if (scm_is_true (definep))
+ scm_c_issue_deprecation_warning
+ ("scm_sym2var is deprecated. Use scm_define or scm_module_define\n"
+ "to define variables. In some rare cases you may need\n"
+ "scm_module_ensure_local_variable.");
+ else
+ scm_c_issue_deprecation_warning
+ ("scm_sym2var is deprecated. Use scm_module_variable to look up\n"
+ "variables.");
+
+ if (SCM_NIMP (proc))
+ {
+ if (SCM_EVAL_CLOSURE_P (proc))
+ {
+ /* Bypass evaluator in the standard case. */
+ var = scm_eval_closure_lookup (proc, sym, definep);
+ }
+ else
+ var = scm_call_2 (proc, sym, definep);
+ }
+ else
+ {
+ if (scm_is_false (definep))
+ var = scm_module_variable (scm_the_root_module (), sym);
+ else
+ var = scm_module_ensure_local_variable (scm_the_root_module (), sym);
+ }
+
+ if (scm_is_true (var) && !SCM_VARIABLEP (var))
+ SCM_MISC_ERROR ("~S is not bound to a variable", scm_list_1 (sym));
+
+ return var;
+}
+#undef FUNC_NAME
+
+SCM
+scm_lookup_closure_module (SCM proc)
+{
+ scm_c_issue_deprecation_warning
+ ("Eval closures are deprecated. See \"Accessing Modules From C\" in\n"
+ "the manual, for replacements.");
+
+ if (scm_is_false (proc))
+ return scm_the_root_module ();
+ else if (SCM_EVAL_CLOSURE_P (proc))
+ return SCM_PACK (SCM_SMOB_DATA (proc));
+ else
+ /* FIXME: The `module' property is no longer set on eval closures, as it
+ introduced a circular reference that precludes garbage collection of
+ modules with the current weak hash table semantics (see
+ http://lists.gnu.org/archive/html/guile-devel/2009-01/msg00102.html and
+ http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/2465
+ for details). Since it doesn't appear to be used (only in this
+ function, which has 1 caller), we no longer extend
+ `set-module-eval-closure!' to set the `module' property. */
+ abort ();
+}
+
+SCM
+scm_module_lookup_closure (SCM module)
+{
+ scm_c_issue_deprecation_warning
+ ("Eval closures are deprecated. See \"Accessing Modules From C\" in\n"
+ "the manual, for replacements.");
+
+ if (scm_is_false (module))
+ return SCM_BOOL_F;
+ else
+ return SCM_MODULE_EVAL_CLOSURE (module);
+}
+
+SCM
+scm_current_module_lookup_closure ()
+{
+ scm_c_issue_deprecation_warning
+ ("Eval closures are deprecated. See \"Accessing Modules From C\" in\n"
+ "the manual, for replacements.");
+
+ if (scm_module_system_booted_p)
+ return scm_module_lookup_closure (scm_current_module ());
+ else
+ return SCM_BOOL_F;
+}
+
+scm_t_bits scm_tc16_eval_closure;
+
+#define SCM_F_EVAL_CLOSURE_INTERFACE (1<<0)
+#define SCM_EVAL_CLOSURE_INTERFACE_P(e) \
+ (SCM_SMOB_FLAGS (e) & SCM_F_EVAL_CLOSURE_INTERFACE)
+
+/* NOTE: This function may be called by a smob application
+ or from another C function directly. */
+SCM
+scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep)
+{
+ SCM module = SCM_PACK (SCM_SMOB_DATA (eclo));
+
+ scm_c_issue_deprecation_warning
+ ("Eval closures are deprecated. See \"Accessing Modules From C\" in\n"
+ "the manual, for replacements.");
+
+ if (scm_is_true (definep))
+ {
+ if (SCM_EVAL_CLOSURE_INTERFACE_P (eclo))
+ return SCM_BOOL_F;
+ return scm_module_ensure_local_variable (module, sym);
+ }
+ else
+ return scm_module_variable (module, sym);
+}
+
+SCM_DEFINE (scm_standard_eval_closure, "standard-eval-closure", 1, 0, 0,
+ (SCM module),
+ "Return an eval closure for the module @var{module}.")
+#define FUNC_NAME s_scm_standard_eval_closure
+{
+ scm_c_issue_deprecation_warning
+ ("Eval closures are deprecated. See \"Accessing Modules From C\" in\n"
+ "the manual, for replacements.");
+
+ SCM_RETURN_NEWSMOB (scm_tc16_eval_closure, SCM_UNPACK (module));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_standard_interface_eval_closure,
+ "standard-interface-eval-closure", 1, 0, 0,
+ (SCM module),
+ "Return a interface eval closure for the module @var{module}. "
+ "Such a closure does not allow new bindings to be added.")
+#define FUNC_NAME s_scm_standard_interface_eval_closure
+{
+ scm_c_issue_deprecation_warning
+ ("Eval closures are deprecated. See \"Accessing Modules From C\" in\n"
+ "the manual, for replacements.");
+
+ SCM_RETURN_NEWSMOB (scm_tc16_eval_closure | (SCM_F_EVAL_CLOSURE_INTERFACE<<16),
+ SCM_UNPACK (module));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_eval_closure_module,
+ "eval-closure-module", 1, 0, 0,
+ (SCM eval_closure),
+ "Return the module associated with this eval closure.")
+/* the idea is that eval closures are really not the way to do things, they're
+ superfluous given our module system. this function lets mmacros migrate away
+ from eval closures. */
+#define FUNC_NAME s_scm_eval_closure_module
+{
+ scm_c_issue_deprecation_warning
+ ("Eval closures are deprecated. See \"Accessing Modules From C\" in\n"
+ "the manual, for replacements.");
+
+ SCM_MAKE_VALIDATE_MSG (SCM_ARG1, eval_closure, EVAL_CLOSURE_P,
+ "eval-closure");
+ return SCM_SMOB_OBJECT (eval_closure);
+}
+#undef FUNC_NAME
+
+
+\f
+
+SCM_DEFINE (scm_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0,
+ (SCM handle),
+ "Return the vtable tag of the structure @var{handle}.")
+#define FUNC_NAME s_scm_struct_vtable_tag
+{
+ SCM_VALIDATE_VTABLE (1, handle);
+ scm_c_issue_deprecation_warning
+ ("struct-vtable-tag is deprecated. What were you doing with it anyway?");
+
+ return scm_from_unsigned_integer
+ (((scm_t_bits)SCM_STRUCT_DATA (handle)) >> 3);
+}
+#undef FUNC_NAME
+
+
+\f
+
+SCM_DEFINE (scm_generalized_vector_p, "generalized-vector?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a vector, string,\n"
+ "bitvector, or uniform numeric vector.")
+#define FUNC_NAME s_scm_generalized_vector_p
+{
+ scm_c_issue_deprecation_warning
+ ("generalized-vector? is deprecated. Use array? and check the "
+ "array-rank instead.");
+ return scm_from_bool (scm_is_generalized_vector (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_generalized_vector_length, "generalized-vector-length", 1, 0, 0,
+ (SCM v),
+ "Return the length of the generalized vector @var{v}.")
+#define FUNC_NAME s_scm_generalized_vector_length
+{
+ scm_c_issue_deprecation_warning
+ ("generalized-vector-length is deprecated. Use array-length instead.");
+ return scm_from_size_t (scm_c_generalized_vector_length (v));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_generalized_vector_ref, "generalized-vector-ref", 2, 0, 0,
+ (SCM v, SCM idx),
+ "Return the element at index @var{idx} of the\n"
+ "generalized vector @var{v}.")
+#define FUNC_NAME s_scm_generalized_vector_ref
+{
+ scm_c_issue_deprecation_warning
+ ("generalized-vector-ref is deprecated. Use array-ref instead.");
+ return scm_c_generalized_vector_ref (v, scm_to_size_t (idx));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_generalized_vector_set_x, "generalized-vector-set!", 3, 0, 0,
+ (SCM v, SCM idx, SCM val),
+ "Set the element at index @var{idx} of the\n"
+ "generalized vector @var{v} to @var{val}.")
+#define FUNC_NAME s_scm_generalized_vector_set_x
+{
+ scm_c_issue_deprecation_warning
+ ("generalized-vector-set! is deprecated. Use array-set! instead. "
+ "Note the change in argument order!");
+ scm_c_generalized_vector_set_x (v, scm_to_size_t (idx), val);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_generalized_vector_to_list, "generalized-vector->list", 1, 0, 0,
+ (SCM v),
+ "Return a new list whose elements are the elements of the\n"
+ "generalized vector @var{v}.")
+#define FUNC_NAME s_scm_generalized_vector_to_list
+{
+ /* FIXME: This duplicates `array_to_list'. */
+ SCM ret = SCM_EOL;
+ long inc;
+ ssize_t pos, i;
+ scm_t_array_handle h;
+
+ scm_c_issue_deprecation_warning
+ ("generalized-vector->list is deprecated. Use array->list instead.");
+
+ scm_generalized_vector_get_handle (v, &h);
+
+ i = h.dims[0].ubnd - h.dims[0].lbnd + 1;
+ inc = h.dims[0].inc;
+ pos = (i - 1) * inc;
+
+ for (; i > 0; i--, pos -= inc)
+ ret = scm_cons (h.impl->vref (&h, h.base + pos), ret);
+
+ scm_array_handle_release (&h);
+ return ret;
+}
+#undef FUNC_NAME
+
+
+\f
+
+extern SCM
+scm_c_program_source (SCM program, size_t ip)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_c_program_source is deprecated. Use scm_program_source instead.");
+
+ return scm_program_source (program, scm_from_size_t (ip), SCM_UNBOUND);
+}
+
+
+\f
+
+SCM_DEFINE (scm_gc_live_object_stats, "gc-live-object-stats", 0, 0, 0,
+ (),
+ "Return an alist of statistics of the current live objects. ")
+#define FUNC_NAME s_scm_gc_live_object_stats
+{
+ scm_c_issue_deprecation_warning
+ ("gc-live-object-stats is deprecated. There is no replacement,\n"
+ "unfortunately.");
+
+ return SCM_EOL;
+}
+#undef FUNC_NAME
+
+
+\f
+
+SCM_DEFINE (scm_htons, "htons", 1, 0, 0,
+ (SCM value),
+ "Convert a 16 bit quantity from host to network byte ordering.\n"
+ "@var{value} is packed into 2 bytes, which are then converted\n"
+ "and returned as a new integer.")
+#define FUNC_NAME s_scm_htons
+{
+ scm_c_issue_deprecation_warning
+ ("htons is deprecated. Use bytevector-u16-set! and bytevector-u16-ref "
+ "with big endianness.");
+
+ return scm_from_ushort (htons (scm_to_ushort (value)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_ntohs, "ntohs", 1, 0, 0,
+ (SCM value),
+ "Convert a 16 bit quantity from network to host byte ordering.\n"
+ "@var{value} is packed into 2 bytes, which are then converted\n"
+ "and returned as a new integer.")
+#define FUNC_NAME s_scm_ntohs
+{
+ scm_c_issue_deprecation_warning
+ ("ntohs is deprecated. Use bytevector-u16-set! and bytevector-u16-ref "
+ "with big endianness.");
+
+ return scm_from_ushort (ntohs (scm_to_ushort (value)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_htonl, "htonl", 1, 0, 0,
+ (SCM value),
+ "Convert a 32 bit quantity from host to network byte ordering.\n"
+ "@var{value} is packed into 4 bytes, which are then converted\n"
+ "and returned as a new integer.")
+#define FUNC_NAME s_scm_htonl
+{
+ scm_c_issue_deprecation_warning
+ ("htonl is deprecated. Use bytevector-u32-set! and bytevector-u32-ref "
+ "with big endianness.");
+
+ return scm_from_ulong (htonl (scm_to_uint32 (value)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_ntohl, "ntohl", 1, 0, 0,
+ (SCM value),
+ "Convert a 32 bit quantity from network to host byte ordering.\n"
+ "@var{value} is packed into 4 bytes, which are then converted\n"
+ "and returned as a new integer.")
+#define FUNC_NAME s_scm_ntohl
+{
+ scm_c_issue_deprecation_warning
+ ("ntohl is deprecated. Use bytevector-u32-set! and bytevector-u32-ref "
+ "with big endianness.");
+
+ return scm_from_ulong (ntohl (scm_to_uint32 (value)));
+}
+#undef FUNC_NAME
+
+
+\f
+
+void
+scm_i_init_deprecated ()
+{
+ properties_whash = scm_make_weak_key_hash_table (SCM_UNDEFINED);
+ scm_struct_table = scm_make_hash_table (SCM_UNDEFINED);
+ scm_tc16_eval_closure = scm_make_smob_type ("eval-closure", 0);
+ scm_set_smob_apply (scm_tc16_eval_closure, scm_eval_closure_lookup, 2, 0, 0);
+
#include "libguile/deprecated.x"
}
HCoop / bpt / guile.git / blobdiff