X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/3452e6667f9c9a83004a38ed146d26aed8c17754..a2689737679cf2553c118a1d96de7c9ddfec62b0:/libguile/deprecated.c diff --git a/libguile/deprecated.c b/libguile/deprecated.c index 30e939b44..f428bd4bf 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -2,7 +2,7 @@ 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 @@ -28,6 +28,11 @@ #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" @@ -36,7 +41,6 @@ #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" @@ -48,13 +52,16 @@ #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 #include #include @@ -70,17 +77,6 @@ char *scm_isymnames[] = }; -/* From eval.c: Error messages of the evaluator. These were deprecated in - * guile 1.7.0 on 2003-06-02. */ -const char scm_s_expression[] = "missing or extra expression"; -const char scm_s_test[] = "bad test"; -const char scm_s_body[] = "bad body"; -const char scm_s_bindings[] = "bad bindings"; -const char scm_s_variable[] = "bad variable"; -const char scm_s_clauses[] = "bad or missing clauses"; -const char scm_s_formals[] = "bad formals"; - - SCM_REGISTER_PROC(s_substring_move_left_x, "substring-move-left!", 5, 0, 0, scm_substring_move_x); SCM_REGISTER_PROC(s_substring_move_right_x, "substring-move-right!", 5, 0, 0, scm_substring_move_x); @@ -259,29 +255,16 @@ static SCM try_module_autoload_var; 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 -scm_the_root_module () -{ - init_module_stuff (); - scm_c_issue_deprecation_warning ("`scm_the_root_module' is deprecated. " - "Use `scm_c_resolve_module (\"guile\")' " - "instead."); - - return scm_c_resolve_module ("guile"); -} - static SCM scm_module_full_name (SCM name) { @@ -446,7 +429,7 @@ scm_create_hook (const char *name, int n_args) { SCM hook = scm_make_hook (scm_from_int (n_args)); scm_c_define (name, hook); - return scm_permanent_object (hook); + return hook; } } @@ -531,38 +514,6 @@ SCM_DEFINE (scm_read_and_eval_x, "read-and-eval!", 0, 1, 0, } #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. @@ -648,7 +599,7 @@ scm_smob_free (SCM obj) "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; } @@ -1237,6 +1188,58 @@ scm_round (double x) 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) { @@ -1330,65 +1333,222 @@ scm_vector_equal_p (SCM x, SCM y) 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 +{ + size_t width; + 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); -} + scm_c_issue_deprecation_warning + ("`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); -} + width = scm_to_size_t (scm_uniform_vector_element_size (uvec)); -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); + return scm_get_bytevector_n_x (port_or_fd, uvec, + scm_from_size_t (scm_to_size_t (start)*width), + scm_from_size_t ((scm_to_size_t (end) + - scm_to_size_t (start)) + * width)); } +#undef FUNC_NAME -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); +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 width; + SCM_VALIDATE_BYTEVECTOR (SCM_ARG1, uvec); + port_or_fd = SCM_COERCE_OUTPORT (port_or_fd); + + scm_c_issue_deprecation_warning + ("`uniform-vector-write' is deprecated. Use `put-bytevector' from\n" + "`(rnrs io ports)' instead."); + + width = scm_to_size_t (scm_uniform_vector_element_size (uvec)); + + return scm_put_bytevector (port_or_fd, uvec, + scm_from_size_t (scm_to_size_t (start)*width), + scm_from_size_t ((scm_to_size_t (end) + - scm_to_size_t (start)) + * width)); } +#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) @@ -1438,14 +1598,6 @@ scm_i_deprecated_dynwinds (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) { @@ -1465,7 +1617,9 @@ scm_i_fluidp (SCM x) /* Networking. */ -SCM_DEFINE (scm_inet_aton, "inet-aton", 1, 0, 0, +#ifdef HAVE_NETWORKING + +SCM_DEFINE (scm_inet_aton, "inet-aton", 1, 0, 0, (SCM address), "Convert an IPv4 Internet address from printable string\n" "(dotted decimal notation) to an integer. E.g.,\n\n" @@ -1482,7 +1636,7 @@ SCM_DEFINE (scm_inet_aton, "inet-aton", 1, 0, 0, #undef FUNC_NAME -SCM_DEFINE (scm_inet_ntoa, "inet-ntoa", 1, 0, 0, +SCM_DEFINE (scm_inet_ntoa, "inet-ntoa", 1, 0, 0, (SCM inetid), "Convert an IPv4 Internet address to a printable\n" "(dotted decimal notation) string. E.g.,\n\n" @@ -1498,6 +1652,7 @@ SCM_DEFINE (scm_inet_ntoa, "inet-ntoa", 1, 0, 0, } #undef FUNC_NAME +#endif /* HAVE_NETWORKING */ void @@ -1592,6 +1747,45 @@ scm_gc_set_debug_check_freelist_x (SCM flag) #endif +/* Trampolines + * + * Trampolines were an intent to speed up calling the same Scheme procedure many + * times from C. + * + * However, this was the wrong thing to optimize; if you really know what you're + * calling, call its function directly, otherwise you're in Scheme-land, and we + * have many better tricks there (inlining, for example, which can remove the + * need for closures and free variables). + * + * Also, in the normal debugging case, trampolines were being computed but not + * used. Silliness. + */ + +scm_t_trampoline_0 +scm_trampoline_0 (SCM proc) +{ + scm_c_issue_deprecation_warning + ("`scm_trampoline_0' is deprecated. Just use `scm_call_0' instead."); + return scm_call_0; +} + +scm_t_trampoline_1 +scm_trampoline_1 (SCM proc) +{ + scm_c_issue_deprecation_warning + ("`scm_trampoline_1' is deprecated. Just use `scm_call_1' instead."); + return scm_call_1; +} + +scm_t_trampoline_2 +scm_trampoline_2 (SCM proc) +{ + scm_c_issue_deprecation_warning + ("`scm_trampoline_2' is deprecated. Just use `scm_call_2' instead."); + return scm_call_2; +} + + void scm_i_init_deprecated () {