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 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 "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 <math.h>
#include <stdio.h>
#include <string.h>
static void
init_module_stuff ()
{
-#define PERM(x) scm_permanent_object(x)
-
if (module_prefix == SCM_BOOL_F)
{
- 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");
}
}
{
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 formore 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_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
+
+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))
+ func = scm_dynamic_func (func, dobj);
+ 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);
+}
+
+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);
+}
+
+int scm_internal_select (int fds,
+ SELECT_TYPE *rfds,
+ SELECT_TYPE *wfds,
+ SELECT_TYPE *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);
+}
+
\f
+
void
scm_i_init_deprecated ()
{
HCoop / bpt / guile.git / blobdiff