diff --git a/libguile/async.c b/libguile/async.c index 141244874..0a08d0c0e 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2006, 2008, 2009, 2010 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2006, 2008, 2009, 2010, 2011 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 @@ -22,8 +22,6 @@ # include #endif -#define SCM_BUILDING_DEPRECATED_CODE - #include "libguile/_scm.h" #include "libguile/eval.h" #include "libguile/throw.h" @@ -170,23 +168,6 @@ scm_async_click () } } -#if (SCM_ENABLE_DEPRECATED == 1) - -SCM_DEFINE (scm_system_async, "system-async", 1, 0, 0, - (SCM thunk), - "This function is deprecated. You can use @var{thunk} directly\n" - "instead of explicitly creating an async object.\n") -#define FUNC_NAME s_scm_system_async -{ - scm_c_issue_deprecation_warning - ("'system-async' is deprecated. " - "Use the procedure directly with 'system-async-mark'."); - return thunk; -} -#undef FUNC_NAME - -#endif /* SCM_ENABLE_DEPRECATED == 1 */ - void scm_i_queue_async_cell (SCM c, scm_i_thread *t) { @@ -341,47 +322,6 @@ SCM_DEFINE (scm_noop, "noop", 0, 0, 1, -#if (SCM_ENABLE_DEPRECATED == 1) - -SCM_DEFINE (scm_unmask_signals, "unmask-signals", 0, 0, 0, - (), - "Unmask signals. The returned value is not specified.") -#define FUNC_NAME s_scm_unmask_signals -{ - scm_i_thread *t = SCM_I_CURRENT_THREAD; - - scm_c_issue_deprecation_warning - ("'unmask-signals' is deprecated. " - "Use 'call-with-blocked-asyncs' instead."); - - if (t->block_asyncs == 0) - SCM_MISC_ERROR ("signals already unmasked", SCM_EOL); - t->block_asyncs = 0; - scm_async_click (); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_mask_signals, "mask-signals", 0, 0, 0, - (), - "Mask signals. The returned value is not specified.") -#define FUNC_NAME s_scm_mask_signals -{ - scm_i_thread *t = SCM_I_CURRENT_THREAD; - - scm_c_issue_deprecation_warning - ("'mask-signals' is deprecated. Use 'call-with-blocked-asyncs' instead."); - - if (t->block_asyncs > 0) - SCM_MISC_ERROR ("signals already masked", SCM_EOL); - t->block_asyncs = 1; - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -#endif /* SCM_ENABLE_DEPRECATED == 1 */ - static void increase_block (void *data) { diff --git a/libguile/async.h b/libguile/async.h index ceb2b960b..2214f679b 100644 --- a/libguile/async.h +++ b/libguile/async.h @@ -3,7 +3,7 @@ #ifndef SCM_ASYNC_H #define SCM_ASYNC_H -/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2005, 2006, 2008, 2009 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2005, 2006, 2008, 2009, 2011 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 @@ -87,14 +87,6 @@ SCM_API void scm_critical_section_end (void); SCM_INTERNAL void scm_init_async (void); -#if (SCM_ENABLE_DEPRECATED == 1) - -SCM_DEPRECATED SCM scm_system_async (SCM thunk); -SCM_DEPRECATED SCM scm_unmask_signals (void); -SCM_DEPRECATED SCM scm_mask_signals (void); - -#endif - #endif /* SCM_ASYNC_H */ /* diff --git a/libguile/debug.h b/libguile/debug.h index d862abab4..0749d283c 100644 --- a/libguile/debug.h +++ b/libguile/debug.h @@ -3,7 +3,7 @@ #ifndef SCM_DEBUG_H #define SCM_DEBUG_H -/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010 +/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010,2011 * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or @@ -52,18 +52,6 @@ SCM_INTERNAL void scm_init_debug (void); SCM_API SCM scm_debug_hang (SCM obj); #endif /*GUILE_DEBUG*/ -#if SCM_ENABLE_DEPRECATED == 1 - -#define CHECK_ENTRY scm_check_entry_p -#define CHECK_APPLY scm_check_apply_p -#define CHECK_EXIT scm_check_exit_p - -/* Deprecated in guile 1.7.0 on 2004-03-29. */ -#define SCM_DEBUGGINGP scm_debug_mode_p -#define scm_debug_mode scm_debug_mode_p - -#endif - #endif /* SCM_DEBUG_H */ /* diff --git a/libguile/deprecated.c b/libguile/deprecated.c index 41e4dbcd3..0c5531630 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -27,2558 +27,12 @@ #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/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/eval.h" -#include "libguile/smob.h" -#include "libguile/procprop.h" -#include "libguile/vectors.h" -#include "libguile/hashtab.h" -#include "libguile/struct.h" -#include "libguile/variable.h" -#include "libguile/fluids.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 -#include -#include - -#include #if (SCM_ENABLE_DEPRECATED == 1) -/* From print.c: Internal symbol names of isyms. Deprecated in guile 1.7.0 on - * 2004-04-22. */ -char *scm_isymnames[] = -{ - "#@" -}; - - -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); - -SCM -scm_wta (SCM arg, const char *pos, const char *s_subr) -{ - if (!s_subr || !*s_subr) - s_subr = NULL; - if ((~0x1fL) & (long) pos) - { - /* error string supplied. */ - scm_misc_error (s_subr, pos, scm_list_1 (arg)); - } - else - { - /* numerical error code. */ - scm_t_bits error = (scm_t_bits) pos; - - switch (error) - { - case SCM_ARGn: - scm_wrong_type_arg (s_subr, 0, arg); - case SCM_ARG1: - scm_wrong_type_arg (s_subr, 1, arg); - case SCM_ARG2: - scm_wrong_type_arg (s_subr, 2, arg); - case SCM_ARG3: - scm_wrong_type_arg (s_subr, 3, arg); - case SCM_ARG4: - scm_wrong_type_arg (s_subr, 4, arg); - case SCM_ARG5: - scm_wrong_type_arg (s_subr, 5, arg); - case SCM_ARG6: - scm_wrong_type_arg (s_subr, 6, arg); - case SCM_ARG7: - scm_wrong_type_arg (s_subr, 7, arg); - case SCM_WNA: - scm_wrong_num_args (arg); - case SCM_OUTOFRANGE: - scm_out_of_range (s_subr, arg); - case SCM_NALLOC: - scm_memory_error (s_subr); - default: - /* this shouldn't happen. */ - scm_misc_error (s_subr, "Unknown error", SCM_EOL); - } - } - return SCM_UNSPECIFIED; -} - -/* Module registry - */ - -/* We can't use SCM objects here. One should be able to call - SCM_REGISTER_MODULE from a C++ constructor for a static - object. This happens before main and thus before libguile is - initialized. */ - -struct moddata { - struct moddata *link; - char *module_name; - void *init_func; -}; - -static struct moddata *registered_mods = NULL; - -void -scm_register_module_xxx (char *module_name, void *init_func) -{ - struct moddata *md; - - scm_c_issue_deprecation_warning - ("`scm_register_module_xxx' is deprecated. Use extensions instead."); - - /* XXX - should we (and can we) DEFER_INTS here? */ - - for (md = registered_mods; md; md = md->link) - if (!strcmp (md->module_name, module_name)) - { - md->init_func = init_func; - return; - } - - md = (struct moddata *) malloc (sizeof (struct moddata)); - if (md == NULL) - { - fprintf (stderr, - "guile: can't register module (%s): not enough memory", - module_name); - return; - } - - md->module_name = module_name; - md->init_func = init_func; - md->link = registered_mods; - registered_mods = md; -} - -SCM_DEFINE (scm_registered_modules, "c-registered-modules", 0, 0, 0, - (), - "Return a list of the object code modules that have been imported into\n" - "the current Guile process. Each element of the list is a pair whose\n" - "car is the name of the module, and whose cdr is the function handle\n" - "for that module's initializer function. The name is the string that\n" - "has been passed to scm_register_module_xxx.") -#define FUNC_NAME s_scm_registered_modules -{ - SCM res; - struct moddata *md; - - res = SCM_EOL; - for (md = registered_mods; md; md = md->link) - res = scm_cons (scm_cons (scm_from_locale_string (md->module_name), - scm_from_ulong ((unsigned long) md->init_func)), - res); - return res; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_clear_registered_modules, "c-clear-registered-modules", 0, 0, 0, - (), - "Destroy the list of modules registered with the current Guile process.\n" - "The return value is unspecified. @strong{Warning:} this function does\n" - "not actually unlink or deallocate these modules, but only destroys the\n" - "records of which modules have been loaded. It should therefore be used\n" - "only by module bookkeeping operations.") -#define FUNC_NAME s_scm_clear_registered_modules -{ - struct moddata *md1, *md2; - - SCM_CRITICAL_SECTION_START; - - for (md1 = registered_mods; md1; md1 = md2) - { - md2 = md1->link; - free (md1); - } - registered_mods = NULL; - - SCM_CRITICAL_SECTION_END; - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -void -scm_remember (SCM *ptr) -{ - scm_c_issue_deprecation_warning ("`scm_remember' is deprecated. " - "Use the `scm_remember_upto_here*' family of functions instead."); -} - -SCM -scm_protect_object (SCM obj) -{ - scm_c_issue_deprecation_warning ("`scm_protect_object' is deprecated. " - "Use `scm_gc_protect_object' instead."); - return scm_gc_protect_object (obj); -} - -SCM -scm_unprotect_object (SCM obj) -{ - scm_c_issue_deprecation_warning ("`scm_unprotect_object' is deprecated. " - "Use `scm_gc_unprotect_object' instead."); - return scm_gc_unprotect_object (obj); -} - -SCM_SYMBOL (scm_sym_app, "app"); -SCM_SYMBOL (scm_sym_modules, "modules"); -static SCM module_prefix = SCM_BOOL_F; -static SCM make_modules_in_var; -static SCM beautify_user_module_x_var; -static SCM try_module_autoload_var; - -static void -init_module_stuff () -{ - if (module_prefix == SCM_BOOL_F) - { - 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 = - scm_c_lookup ("beautify-user-module!"); - try_module_autoload_var = scm_c_lookup ("try-module-autoload"); - } -} - -static SCM -scm_module_full_name (SCM name) -{ - init_module_stuff (); - if (scm_is_eq (SCM_CAR (name), scm_sym_app)) - return name; - else - return scm_append (scm_list_2 (module_prefix, name)); -} - -SCM -scm_make_module (SCM name) -{ - init_module_stuff (); - scm_c_issue_deprecation_warning ("`scm_make_module' is deprecated. " - "Use `scm_c_define_module instead."); - - return scm_call_2 (SCM_VARIABLE_REF (make_modules_in_var), - scm_the_root_module (), - scm_module_full_name (name)); -} - -SCM -scm_ensure_user_module (SCM module) -{ - init_module_stuff (); - scm_c_issue_deprecation_warning ("`scm_ensure_user_module' is deprecated. " - "Use `scm_c_define_module instead."); - - scm_call_1 (SCM_VARIABLE_REF (beautify_user_module_x_var), module); - return SCM_UNSPECIFIED; -} - -SCM -scm_load_scheme_module (SCM name) -{ - init_module_stuff (); - scm_c_issue_deprecation_warning ("`scm_load_scheme_module' is deprecated. " - "Use `scm_c_resolve_module instead."); - - return scm_call_1 (SCM_VARIABLE_REF (try_module_autoload_var), name); -} - -/* This is implemented in C solely for SCM_COERCE_OUTPORT ... */ - -static void -maybe_close_port (void *data, SCM port) -{ - SCM except_set = (SCM) data; - - while (!scm_is_null (except_set)) - { - SCM p = SCM_COERCE_OUTPORT (SCM_CAR (except_set)); - if (scm_is_eq (p, port)) - return; - except_set = SCM_CDR (except_set); - } - - scm_close_port (port); -} - -SCM_DEFINE (scm_close_all_ports_except, "close-all-ports-except", 0, 0, 1, - (SCM ports), - "[DEPRECATED] Close all open file ports used by the interpreter\n" - "except for those supplied as arguments. This procedure\n" - "was intended to be used before an exec call to close file descriptors\n" - "which are not needed in the new process. However it has the\n" - "undesirable side effect of flushing buffers, so it's deprecated.\n" - "Use port-for-each instead.") -#define FUNC_NAME s_scm_close_all_ports_except -{ - 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); - - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_variable_set_name_hint, "variable-set-name-hint!", 2, 0, 0, - (SCM var, SCM hint), - "Do not use this function.") -#define FUNC_NAME s_scm_variable_set_name_hint -{ - SCM_VALIDATE_VARIABLE (1, var); - SCM_VALIDATE_SYMBOL (2, hint); - scm_c_issue_deprecation_warning - ("'variable-set-name-hint!' is deprecated. Do not use it."); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_builtin_variable, "builtin-variable", 1, 0, 0, - (SCM name), - "Do not use this function.") -#define FUNC_NAME s_scm_builtin_variable -{ - SCM_VALIDATE_SYMBOL (1,name); - scm_c_issue_deprecation_warning ("`builtin-variable' is deprecated. " - "Use module system operations instead."); - return scm_sym2var (name, SCM_BOOL_F, SCM_BOOL_T); -} -#undef FUNC_NAME - -SCM -scm_makstr (size_t len, int dummy) -{ - scm_c_issue_deprecation_warning - ("'scm_makstr' is deprecated. Use 'scm_c_make_string' instead."); - return scm_c_make_string (len, SCM_UNDEFINED); -} - -SCM -scm_makfromstr (const char *src, size_t len, int dummy SCM_UNUSED) -{ - scm_c_issue_deprecation_warning ("`scm_makfromstr' is deprecated. " - "Use `scm_from_locale_stringn' instead."); - - return scm_from_locale_stringn (src, len); -} - -SCM -scm_internal_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata) -{ - scm_c_issue_deprecation_warning ("`scm_internal_with_fluids' is deprecated. " - "Use `scm_c_with_fluids' instead."); - - return scm_c_with_fluids (fluids, values, cproc, cdata); -} - -SCM -scm_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)()) -{ - scm_c_issue_deprecation_warning - ("`scm_make_gsubr' is deprecated. Use `scm_c_define_gsubr' instead."); - - return scm_c_define_gsubr (name, req, opt, rst, fcn); -} - -SCM -scm_make_gsubr_with_generic (const char *name, - int req, int opt, int rst, - SCM (*fcn)(), SCM *gf) -{ - scm_c_issue_deprecation_warning - ("`scm_make_gsubr_with_generic' is deprecated. " - "Use `scm_c_define_gsubr_with_generic' instead."); - - return scm_c_define_gsubr_with_generic (name, req, opt, rst, fcn, gf); -} - -SCM -scm_create_hook (const char *name, int n_args) -{ - scm_c_issue_deprecation_warning - ("'scm_create_hook' is deprecated. " - "Use 'scm_make_hook' and 'scm_c_define' instead."); - { - SCM hook = scm_make_hook (scm_from_int (n_args)); - scm_c_define (name, hook); - return hook; - } -} - -SCM_DEFINE (scm_sloppy_memq, "sloppy-memq", 2, 0, 0, - (SCM x, SCM lst), - "This procedure behaves like @code{memq}, but does no type or error checking.\n" - "Its use is recommended only in writing Guile internals,\n" - "not for high-level Scheme programs.") -#define FUNC_NAME s_scm_sloppy_memq -{ - scm_c_issue_deprecation_warning - ("'sloppy-memq' is deprecated. Use 'memq' instead."); - - for(; scm_is_pair (lst); lst = SCM_CDR(lst)) - { - if (scm_is_eq (SCM_CAR (lst), x)) - return lst; - } - return lst; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_sloppy_memv, "sloppy-memv", 2, 0, 0, - (SCM x, SCM lst), - "This procedure behaves like @code{memv}, but does no type or error checking.\n" - "Its use is recommended only in writing Guile internals,\n" - "not for high-level Scheme programs.") -#define FUNC_NAME s_scm_sloppy_memv -{ - scm_c_issue_deprecation_warning - ("'sloppy-memv' is deprecated. Use 'memv' instead."); - - for(; scm_is_pair (lst); lst = SCM_CDR(lst)) - { - if (! scm_is_false (scm_eqv_p (SCM_CAR (lst), x))) - return lst; - } - return lst; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_sloppy_member, "sloppy-member", 2, 0, 0, - (SCM x, SCM lst), - "This procedure behaves like @code{member}, but does no type or error checking.\n" - "Its use is recommended only in writing Guile internals,\n" - "not for high-level Scheme programs.") -#define FUNC_NAME s_scm_sloppy_member -{ - scm_c_issue_deprecation_warning - ("'sloppy-member' is deprecated. Use 'member' instead."); - - for(; scm_is_pair (lst); lst = SCM_CDR(lst)) - { - if (! scm_is_false (scm_equal_p (SCM_CAR (lst), x))) - return lst; - } - return lst; -} -#undef FUNC_NAME - -SCM_SYMBOL (scm_end_of_file_key, "end-of-file"); - -SCM_DEFINE (scm_read_and_eval_x, "read-and-eval!", 0, 1, 0, - (SCM port), - "Read a form from @var{port} (standard input by default), and evaluate it\n" - "(memoizing it in the process) in the top-level environment. If no data\n" - "is left to be read from @var{port}, an @code{end-of-file} error is\n" - "signalled.") -#define FUNC_NAME s_scm_read_and_eval_x -{ - SCM form; - - scm_c_issue_deprecation_warning - ("'read-and-eval!' is deprecated. Use 'read' and 'eval' instead."); - - form = scm_read (port); - if (SCM_EOF_OBJECT_P (form)) - scm_ithrow (scm_end_of_file_key, SCM_EOL, 1); - return scm_eval_x (form, scm_current_module ()); -} -#undef FUNC_NAME - -/* 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. - */ - -#ifdef _UNICOS -typedef int setjmp_type; -#else -typedef long setjmp_type; -#endif - -struct cce_handler_data { - SCM (*err_filter) (); - void *closure; -}; - -static SCM -invoke_err_filter (void *d, SCM tag, SCM args) -{ - struct cce_handler_data *data = (struct cce_handler_data *)d; - return data->err_filter (SCM_BOOL_F, data->closure); -} - -SCM -scm_call_catching_errors (SCM (*thunk)(), SCM (*err_filter)(), void *closure) -{ - scm_c_issue_deprecation_warning - ("'scm_call_catching_errors' is deprecated. " - "Use 'scm_internal_catch' instead."); - - { - struct cce_handler_data data; - data.err_filter = err_filter; - data.closure = closure; - return scm_internal_catch (SCM_BOOL_T, - (scm_t_catch_body)thunk, closure, - (scm_t_catch_handler)invoke_err_filter, &data); - } -} - -long -scm_make_smob_type_mfpe (char *name, size_t size, - SCM (*mark) (SCM), - size_t (*free) (SCM), - int (*print) (SCM, SCM, scm_print_state *), - SCM (*equalp) (SCM, SCM)) -{ - scm_c_issue_deprecation_warning - ("'scm_make_smob_type_mfpe' is deprecated. " - "Use 'scm_make_smob_type' plus 'scm_set_smob_*' instead."); - - { - long answer = scm_make_smob_type (name, size); - scm_set_smob_mfpe (answer, mark, free, print, equalp); - return answer; - } -} - -void -scm_set_smob_mfpe (long tc, - SCM (*mark) (SCM), - size_t (*free) (SCM), - int (*print) (SCM, SCM, scm_print_state *), - SCM (*equalp) (SCM, SCM)) -{ - scm_c_issue_deprecation_warning - ("'scm_set_smob_mfpe' is deprecated. " - "Use 'scm_set_smob_mark' instead, for example."); - - if (mark) scm_set_smob_mark (tc, mark); - if (free) scm_set_smob_free (tc, free); - if (print) scm_set_smob_print (tc, print); - if (equalp) scm_set_smob_equalp (tc, equalp); -} - -size_t -scm_smob_free (SCM obj) -{ - long n = SCM_SMOBNUM (obj); - - scm_c_issue_deprecation_warning - ("`scm_smob_free' is deprecated. " - "It is no longer needed."); - - if (scm_smobs[n].size > 0) - scm_gc_free ((void *) SCM_SMOB_DATA_1 (obj), - scm_smobs[n].size, SCM_SMOBNAME (n)); - return 0; -} - -SCM -scm_read_0str (char *expr) -{ - scm_c_issue_deprecation_warning - ("scm_read_0str is deprecated. Use scm_c_read_string instead."); - - return scm_c_read_string (expr); -} - -SCM -scm_eval_0str (const char *expr) -{ - scm_c_issue_deprecation_warning - ("scm_eval_0str is deprecated. Use scm_c_eval_string instead."); - - return scm_c_eval_string (expr); -} - -SCM -scm_strprint_obj (SCM obj) -{ - scm_c_issue_deprecation_warning - ("scm_strprint_obj is deprecated. Use scm_object_to_string instead."); - return scm_object_to_string (obj, SCM_UNDEFINED); -} - -char * -scm_i_object_chars (SCM obj) -{ - scm_c_issue_deprecation_warning - ("SCM_CHARS is deprecated. See the manual for alternatives."); - if (SCM_STRINGP (obj)) - return SCM_STRING_CHARS (obj); - if (SCM_SYMBOLP (obj)) - return SCM_SYMBOL_CHARS (obj); - abort (); -} - -long -scm_i_object_length (SCM obj) -{ - scm_c_issue_deprecation_warning - ("SCM_LENGTH is deprecated. " - "Use scm_c_string_length instead, for example, or see the manual."); - if (SCM_STRINGP (obj)) - return SCM_STRING_LENGTH (obj); - if (SCM_SYMBOLP (obj)) - return SCM_SYMBOL_LENGTH (obj); - if (SCM_VECTORP (obj)) - return SCM_VECTOR_LENGTH (obj); - abort (); -} - -SCM -scm_sym2ovcell_soft (SCM sym, SCM obarray) -{ - SCM lsym, z; - size_t hash = scm_i_symbol_hash (sym) % SCM_VECTOR_LENGTH (obarray); - - scm_c_issue_deprecation_warning ("`scm_sym2ovcell_soft' is deprecated. " - "Use hashtables instead."); - - SCM_CRITICAL_SECTION_START; - for (lsym = SCM_VECTOR_REF (obarray, hash); - SCM_NIMP (lsym); - lsym = SCM_CDR (lsym)) - { - z = SCM_CAR (lsym); - if (scm_is_eq (SCM_CAR (z), sym)) - { - SCM_CRITICAL_SECTION_END; - return z; - } - } - SCM_CRITICAL_SECTION_END; - return SCM_BOOL_F; -} - - -SCM -scm_sym2ovcell (SCM sym, SCM obarray) -#define FUNC_NAME "scm_sym2ovcell" -{ - SCM answer; - - scm_c_issue_deprecation_warning ("`scm_sym2ovcell' is deprecated. " - "Use hashtables instead."); - - answer = scm_sym2ovcell_soft (sym, obarray); - if (scm_is_true (answer)) - return answer; - SCM_MISC_ERROR ("uninterned symbol: ~S", scm_list_1 (sym)); - return SCM_UNSPECIFIED; /* not reached */ -} -#undef FUNC_NAME - - -/* Intern a symbol whose name is the LEN characters at NAME in OBARRAY. - - OBARRAY should be a vector of lists, indexed by the name's hash - value, modulo OBARRAY's length. Each list has the form - ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the - value associated with that symbol (in the current module? in the - system module?) - - To "intern" a symbol means: if OBARRAY already contains a symbol by - that name, return its (SYMBOL . VALUE) pair; otherwise, create a - new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the - appropriate list of the OBARRAY, and return the pair. - - If softness is non-zero, don't create a symbol if it isn't already - in OBARRAY; instead, just return #f. - - If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and - return (SYMBOL . SCM_UNDEFINED). */ - - -static SCM -intern_obarray_soft (SCM symbol, SCM obarray, unsigned int softness) -{ - size_t raw_hash = scm_i_symbol_hash (symbol); - size_t hash; - SCM lsym; - - if (scm_is_false (obarray)) - { - if (softness) - return SCM_BOOL_F; - else - return scm_cons (symbol, SCM_UNDEFINED); - } - - hash = raw_hash % SCM_VECTOR_LENGTH (obarray); - - for (lsym = SCM_VECTOR_REF(obarray, hash); - SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) - { - SCM a = SCM_CAR (lsym); - SCM z = SCM_CAR (a); - if (scm_is_eq (z, symbol)) - return a; - } - - if (softness) - { - return SCM_BOOL_F; - } - else - { - SCM cell = scm_cons (symbol, SCM_UNDEFINED); - SCM slot = SCM_VECTOR_REF (obarray, hash); - - SCM_VECTOR_SET (obarray, hash, scm_cons (cell, slot)); - - return cell; - } -} - - -SCM -scm_intern_obarray_soft (const char *name, size_t len, SCM obarray, - unsigned int softness) -{ - SCM symbol = scm_from_locale_symboln (name, len); - - scm_c_issue_deprecation_warning ("`scm_intern_obarray_soft' is deprecated. " - "Use hashtables instead."); - - return intern_obarray_soft (symbol, obarray, softness); -} - -SCM -scm_intern_obarray (const char *name,size_t len,SCM obarray) -{ - scm_c_issue_deprecation_warning ("`scm_intern_obarray' is deprecated. " - "Use hashtables instead."); - - return scm_intern_obarray_soft (name, len, obarray, 0); -} - -/* Lookup the value of the symbol named by the nul-terminated string - NAME in the current module. */ -SCM -scm_symbol_value0 (const char *name) -{ - scm_c_issue_deprecation_warning ("`scm_symbol_value0' is deprecated. " - "Use `scm_lookup' instead."); - - return scm_variable_ref (scm_c_lookup (name)); -} - -SCM_DEFINE (scm_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0, - (SCM o, SCM s, SCM softp), - "Intern a new symbol in @var{obarray}, a symbol table, with name\n" - "@var{string}.\n\n" - "If @var{obarray} is @code{#f}, use the default system symbol table. If\n" - "@var{obarray} is @code{#t}, the symbol should not be interned in any\n" - "symbol table; merely return the pair (@var{symbol}\n" - ". @var{#}).\n\n" - "The @var{soft?} argument determines whether new symbol table entries\n" - "should be created when the specified symbol is not already present in\n" - "@var{obarray}. If @var{soft?} is specified and is a true value, then\n" - "new entries should not be added for symbols not already present in the\n" - "table; instead, simply return @code{#f}.") -#define FUNC_NAME s_scm_string_to_obarray_symbol -{ - SCM vcell; - SCM answer; - int softness; - - SCM_VALIDATE_STRING (2, s); - SCM_ASSERT (scm_is_bool (o) || SCM_VECTORP (o), o, SCM_ARG1, FUNC_NAME); - - scm_c_issue_deprecation_warning ("`string->obarray-symbol' is deprecated. " - "Use hashtables instead."); - - softness = (!SCM_UNBNDP (softp) && scm_is_true(softp)); - /* iron out some screwy calling conventions */ - if (scm_is_false (o)) - { - /* nothing interesting to do here. */ - return scm_string_to_symbol (s); - } - else if (scm_is_eq (o, SCM_BOOL_T)) - o = SCM_BOOL_F; - - vcell = intern_obarray_soft (scm_string_to_symbol (s), o, softness); - if (scm_is_false (vcell)) - return vcell; - answer = SCM_CAR (vcell); - return answer; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_intern_symbol, "intern-symbol", 2, 0, 0, - (SCM o, SCM s), - "Add a new symbol to @var{obarray} with name @var{string}, bound to an\n" - "unspecified initial value. The symbol table is not modified if a symbol\n" - "with this name is already present.") -#define FUNC_NAME s_scm_intern_symbol -{ - size_t hval; - SCM_VALIDATE_SYMBOL (2,s); - if (scm_is_false (o)) - return SCM_UNSPECIFIED; - - scm_c_issue_deprecation_warning ("`intern-symbol' is deprecated. " - "Use hashtables instead."); - - SCM_VALIDATE_VECTOR (1,o); - hval = scm_i_symbol_hash (s) % SCM_VECTOR_LENGTH (o); - /* If the symbol is already interned, simply return. */ - SCM_CRITICAL_SECTION_START; - { - SCM lsym; - SCM sym; - for (lsym = SCM_VECTOR_REF (o, hval); - SCM_NIMP (lsym); - lsym = SCM_CDR (lsym)) - { - sym = SCM_CAR (lsym); - if (scm_is_eq (SCM_CAR (sym), s)) - { - SCM_CRITICAL_SECTION_END; - return SCM_UNSPECIFIED; - } - } - SCM_VECTOR_SET (o, hval, - scm_acons (s, SCM_UNDEFINED, - SCM_VECTOR_REF (o, hval))); - } - SCM_CRITICAL_SECTION_END; - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_unintern_symbol, "unintern-symbol", 2, 0, 0, - (SCM o, SCM s), - "Remove the symbol with name @var{string} from @var{obarray}. This\n" - "function returns @code{#t} if the symbol was present and @code{#f}\n" - "otherwise.") -#define FUNC_NAME s_scm_unintern_symbol -{ - size_t hval; - - scm_c_issue_deprecation_warning ("`unintern-symbol' is deprecated. " - "Use hashtables instead."); - - SCM_VALIDATE_SYMBOL (2,s); - if (scm_is_false (o)) - return SCM_BOOL_F; - SCM_VALIDATE_VECTOR (1,o); - hval = scm_i_symbol_hash (s) % SCM_VECTOR_LENGTH (o); - SCM_CRITICAL_SECTION_START; - { - SCM lsym_follow; - SCM lsym; - SCM sym; - for (lsym = SCM_VECTOR_REF (o, hval), lsym_follow = SCM_BOOL_F; - SCM_NIMP (lsym); - lsym_follow = lsym, lsym = SCM_CDR (lsym)) - { - sym = SCM_CAR (lsym); - if (scm_is_eq (SCM_CAR (sym), s)) - { - /* Found the symbol to unintern. */ - if (scm_is_false (lsym_follow)) - SCM_VECTOR_SET (o, hval, lsym); - else - SCM_SETCDR (lsym_follow, SCM_CDR(lsym)); - SCM_CRITICAL_SECTION_END; - return SCM_BOOL_T; - } - } - } - SCM_CRITICAL_SECTION_END; - return SCM_BOOL_F; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_symbol_binding, "symbol-binding", 2, 0, 0, - (SCM o, SCM s), - "Look up in @var{obarray} the symbol whose name is @var{string}, and\n" - "return the value to which it is bound. If @var{obarray} is @code{#f},\n" - "use the global symbol table. If @var{string} is not interned in\n" - "@var{obarray}, an error is signalled.") -#define FUNC_NAME s_scm_symbol_binding -{ - SCM vcell; - - scm_c_issue_deprecation_warning ("`symbol-binding' is deprecated. " - "Use hashtables instead."); - - SCM_VALIDATE_SYMBOL (2,s); - if (scm_is_false (o)) - return scm_variable_ref (scm_lookup (s)); - SCM_VALIDATE_VECTOR (1,o); - vcell = scm_sym2ovcell (s, o); - return SCM_CDR(vcell); -} -#undef FUNC_NAME - -#if 0 -SCM_DEFINE (scm_symbol_interned_p, "symbol-interned?", 2, 0, 0, - (SCM o, SCM s), - "Return @code{#t} if @var{obarray} contains a symbol with name\n" - "@var{string}, and @code{#f} otherwise.") -#define FUNC_NAME s_scm_symbol_interned_p -{ - SCM vcell; - - scm_c_issue_deprecation_warning ("`symbol-interned?' is deprecated. " - "Use hashtables instead."); - - SCM_VALIDATE_SYMBOL (2,s); - if (scm_is_false (o)) - { - SCM var = scm_sym2var (s, SCM_BOOL_F, SCM_BOOL_F); - if (var != SCM_BOOL_F) - return SCM_BOOL_T; - return SCM_BOOL_F; - } - SCM_VALIDATE_VECTOR (1,o); - vcell = scm_sym2ovcell_soft (s, o); - return (SCM_NIMP(vcell) - ? SCM_BOOL_T - : SCM_BOOL_F); -} -#undef FUNC_NAME -#endif - -SCM_DEFINE (scm_symbol_bound_p, "symbol-bound?", 2, 0, 0, - (SCM o, SCM s), - "Return @code{#t} if @var{obarray} contains a symbol with name\n" - "@var{string} bound to a defined value. This differs from\n" - "@var{symbol-interned?} in that the mere mention of a symbol\n" - "usually causes it to be interned; @code{symbol-bound?}\n" - "determines whether a symbol has been given any meaningful\n" - "value.") -#define FUNC_NAME s_scm_symbol_bound_p -{ - SCM vcell; - - scm_c_issue_deprecation_warning ("`symbol-bound?' is deprecated. " - "Use hashtables instead."); - - SCM_VALIDATE_SYMBOL (2,s); - if (scm_is_false (o)) - { - SCM var = scm_sym2var (s, SCM_BOOL_F, SCM_BOOL_F); - if (SCM_VARIABLEP(var) && !SCM_UNBNDP(SCM_VARIABLE_REF(var))) - return SCM_BOOL_T; - return SCM_BOOL_F; - } - SCM_VALIDATE_VECTOR (1,o); - vcell = scm_sym2ovcell_soft (s, o); - return scm_from_bool (SCM_NIMP (vcell) && !SCM_UNBNDP (SCM_CDR (vcell))); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_symbol_set_x, "symbol-set!", 3, 0, 0, - (SCM o, SCM s, SCM v), - "Find the symbol in @var{obarray} whose name is @var{string}, and rebind\n" - "it to @var{value}. An error is signalled if @var{string} is not present\n" - "in @var{obarray}.") -#define FUNC_NAME s_scm_symbol_set_x -{ - SCM vcell; - - scm_c_issue_deprecation_warning ("`symbol-set!' is deprecated. " - "Use the module system instead."); - - SCM_VALIDATE_SYMBOL (2,s); - if (scm_is_false (o)) - { - scm_define (s, v); - return SCM_UNSPECIFIED; - } - SCM_VALIDATE_VECTOR (1,o); - vcell = scm_sym2ovcell (s, o); - SCM_SETCDR (vcell, v); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -#define MAX_PREFIX_LENGTH 30 - -static int gentemp_counter; - -SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0, - (SCM prefix, SCM obarray), - "Create a new symbol with a name unique in an obarray.\n" - "The name is constructed from an optional string @var{prefix}\n" - "and a counter value. The default prefix is @code{t}. The\n" - "@var{obarray} is specified as a second optional argument.\n" - "Default is the system obarray where all normal symbols are\n" - "interned. The counter is increased by 1 at each\n" - "call. There is no provision for resetting the counter.") -#define FUNC_NAME s_scm_gentemp -{ - char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN]; - char *name = buf; - int n_digits; - size_t len; - - scm_c_issue_deprecation_warning ("`gentemp' is deprecated. " - "Use `gensym' instead."); - - if (SCM_UNBNDP (prefix)) - { - name[0] = 't'; - len = 1; - } - else - { - SCM_VALIDATE_STRING (1, prefix); - len = scm_i_string_length (prefix); - name = scm_to_locale_stringn (prefix, &len); - name = scm_realloc (name, len + SCM_INTBUFLEN); - } - - if (SCM_UNBNDP (obarray)) - return scm_gensym (prefix); - else - SCM_ASSERT ((scm_is_vector (obarray) || SCM_I_WVECTP (obarray)), - obarray, - SCM_ARG2, - FUNC_NAME); - do - n_digits = scm_iint2str (gentemp_counter++, 10, &name[len]); - while (scm_is_true (scm_intern_obarray_soft (name, - len + n_digits, - obarray, - 1))); - { - SCM vcell = scm_intern_obarray_soft (name, - len + n_digits, - obarray, - 0); - if (name != buf) - free (name); - return SCM_CAR (vcell); - } -} -#undef FUNC_NAME - -SCM -scm_i_makinum (scm_t_signed_bits val) -{ - scm_c_issue_deprecation_warning - ("SCM_MAKINUM is deprecated. Use scm_from_int or similar instead."); - return SCM_I_MAKINUM (val); -} - -int -scm_i_inump (SCM obj) -{ - scm_c_issue_deprecation_warning - ("SCM_INUMP is deprecated. Use scm_is_integer or similar instead."); - return SCM_I_INUMP (obj); -} - -scm_t_signed_bits -scm_i_inum (SCM obj) -{ - scm_c_issue_deprecation_warning - ("SCM_INUM is deprecated. Use scm_to_int or similar instead."); - return scm_to_intmax (obj); -} - -char * -scm_c_string2str (SCM obj, char *str, size_t *lenp) -{ - scm_c_issue_deprecation_warning - ("scm_c_string2str is deprecated. Use scm_to_locale_stringbuf or similar instead."); - - if (str == NULL) - { - char *result = scm_to_locale_string (obj); - if (lenp) - *lenp = scm_i_string_length (obj); - return result; - } - else - { - /* Pray that STR is large enough. - */ - size_t len = scm_to_locale_stringbuf (obj, str, SCM_I_SIZE_MAX); - str[len] = '\0'; - if (lenp) - *lenp = len; - return str; - } -} - -char * -scm_c_substring2str (SCM obj, char *str, size_t start, size_t len) -{ - scm_c_issue_deprecation_warning - ("scm_c_substring2str is deprecated. Use scm_substring plus scm_to_locale_stringbuf instead."); - - if (start) - obj = scm_substring (obj, scm_from_size_t (start), SCM_UNDEFINED); - - scm_to_locale_stringbuf (obj, str, len); - return str; -} - -/* Converts the given Scheme symbol OBJ into a C string, containing a copy - of OBJ's content with a trailing null byte. If LENP is non-NULL, set - *LENP to the string's length. - - When STR is non-NULL it receives the copy and is returned by the function, - otherwise new memory is allocated and the caller is responsible for - freeing it via free(). If out of memory, NULL is returned. - - Note that Scheme symbols may contain arbitrary data, including null - characters. This means that null termination is not a reliable way to - determine the length of the returned value. However, the function always - copies the complete contents of OBJ, and sets *LENP to the length of the - scheme symbol (if LENP is non-null). */ -char * -scm_c_symbol2str (SCM obj, char *str, size_t *lenp) -{ - return scm_c_string2str (scm_symbol_to_string (obj), str, lenp); -} - -double -scm_truncate (double x) -{ - scm_c_issue_deprecation_warning - ("scm_truncate is deprecated. Use scm_c_truncate instead."); - return scm_c_truncate (x); -} - -double -scm_round (double x) -{ - scm_c_issue_deprecation_warning - ("scm_round is deprecated. Use scm_c_round instead."); - 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) -{ - scm_c_issue_deprecation_warning - ("SCM_SYMBOL_CHARS is deprecated. Use scm_symbol_to_string."); - - return (char *)scm_i_symbol_chars (sym); -} - -size_t -scm_i_deprecated_symbol_length (SCM sym) -{ - scm_c_issue_deprecation_warning - ("SCM_SYMBOL_LENGTH is deprecated. Use scm_symbol_to_string."); - return scm_i_symbol_length (sym); -} - -int -scm_i_keywordp (SCM obj) -{ - scm_c_issue_deprecation_warning - ("SCM_KEYWORDP is deprecated. Use scm_is_keyword instead."); - return scm_is_keyword (obj); -} - -SCM -scm_i_keywordsym (SCM keyword) -{ - scm_c_issue_deprecation_warning - ("SCM_KEYWORDSYM is deprecated. See scm_keyword_to_symbol instead."); - return scm_keyword_dash_symbol (keyword); -} - -int -scm_i_vectorp (SCM x) -{ - scm_c_issue_deprecation_warning - ("SCM_VECTORP is deprecated. Use scm_is_vector instead."); - return SCM_I_IS_VECTOR (x); -} - -unsigned long -scm_i_vector_length (SCM x) -{ - scm_c_issue_deprecation_warning - ("SCM_VECTOR_LENGTH is deprecated. Use scm_c_vector_length instead."); - return SCM_I_VECTOR_LENGTH (x); -} - -const SCM * -scm_i_velts (SCM x) -{ - scm_c_issue_deprecation_warning - ("SCM_VELTS is deprecated. Use scm_vector_elements instead."); - return SCM_I_VECTOR_ELTS (x); -} - -SCM * -scm_i_writable_velts (SCM x) -{ - scm_c_issue_deprecation_warning - ("SCM_WRITABLE_VELTS is deprecated. " - "Use scm_vector_writable_elements instead."); - return SCM_I_VECTOR_WELTS (x); -} - -SCM -scm_i_vector_ref (SCM x, size_t idx) -{ - scm_c_issue_deprecation_warning - ("SCM_VECTOR_REF is deprecated. " - "Use scm_c_vector_ref or scm_vector_elements instead."); - return scm_c_vector_ref (x, idx); -} - -void -scm_i_vector_set (SCM x, size_t idx, SCM val) -{ - scm_c_issue_deprecation_warning - ("SCM_VECTOR_SET is deprecated. " - "Use scm_c_vector_set_x or scm_vector_writable_elements instead."); - scm_c_vector_set_x (x, idx, val); -} - -SCM -scm_vector_equal_p (SCM x, SCM y) -{ - scm_c_issue_deprecation_warning - ("scm_vector_euqal_p is deprecated. " - "Use scm_equal_p instead."); - return scm_equal_p (x, y); -} - -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); - - scm_c_issue_deprecation_warning - ("`uniform-vector-read!' is deprecated. Use `get-bytevector-n!' from\n" - "`(rnrs io ports)' instead."); - - if (SCM_UNBNDP (port_or_fd)) - port_or_fd = scm_current_input_port (); - - 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_c_issue_deprecation_warning - ("`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 - -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_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) -{ - scm_c_issue_deprecation_warning - ("scm_cur_inp is deprecated. Use scm_current_input_port instead."); - return scm_current_input_port (); -} - -SCM -scm_i_cur_outp (void) -{ - scm_c_issue_deprecation_warning - ("scm_cur_outp is deprecated. Use scm_current_output_port instead."); - return scm_current_output_port (); -} - -SCM -scm_i_cur_errp (void) -{ - scm_c_issue_deprecation_warning - ("scm_cur_errp is deprecated. Use scm_current_error_port instead."); - return scm_current_error_port (); -} - -SCM -scm_i_cur_loadp (void) -{ - scm_c_issue_deprecation_warning - ("scm_cur_loadp is deprecated. Use scm_current_load_port instead."); - return scm_current_load_port (); -} - -SCM -scm_i_progargs (void) -{ - scm_c_issue_deprecation_warning - ("scm_progargs is deprecated. Use scm_program_arguments instead."); - return scm_program_arguments (); -} - -SCM -scm_i_deprecated_dynwinds (void) -{ - scm_c_issue_deprecation_warning - ("scm_dynwinds is deprecated. Do not use it."); - return scm_i_dynwinds (); -} - -SCM_STACKITEM * -scm_i_stack_base (void) -{ - scm_c_issue_deprecation_warning - ("scm_stack_base is deprecated. Do not use it."); - return SCM_I_CURRENT_THREAD->base; -} - -int -scm_i_fluidp (SCM x) -{ - scm_c_issue_deprecation_warning - ("SCM_FLUIDP is deprecated. Use scm_is_fluid instead."); - return scm_is_fluid (x); -} - - -/* Networking. */ - -#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" - "@lisp\n" - "(inet-aton \"127.0.0.1\") @result{} 2130706433\n" - "@end lisp") -#define FUNC_NAME s_scm_inet_aton -{ - scm_c_issue_deprecation_warning - ("`inet-aton' is deprecated. Use `inet-pton' instead."); - - return scm_inet_pton (scm_from_int (AF_INET), address); -} -#undef FUNC_NAME - - -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" - "@lisp\n" - "(inet-ntoa 2130706433) @result{} \"127.0.0.1\"\n" - "@end lisp") -#define FUNC_NAME s_scm_inet_ntoa -{ - scm_c_issue_deprecation_warning - ("`inet-ntoa' is deprecated. Use `inet-ntop' instead."); - - return scm_inet_ntop (scm_from_int (AF_INET), inetid); -} -#undef FUNC_NAME - -#endif /* HAVE_NETWORKING */ - - -void -scm_i_defer_ints_etc () -{ - scm_c_issue_deprecation_warning - ("SCM_DEFER_INTS etc are deprecated. " - "Use a mutex instead if appropriate."); -} - -int -scm_i_mask_ints (void) -{ - scm_c_issue_deprecation_warning ("`scm_mask_ints' is deprecated."); - return (SCM_I_CURRENT_THREAD->block_asyncs != 0); -} - - -SCM -scm_guard (SCM guardian, SCM obj, int throw_p) -{ - scm_c_issue_deprecation_warning - ("scm_guard is deprecated. Use scm_call_1 instead."); - - return scm_call_1 (guardian, obj); -} - -SCM -scm_get_one_zombie (SCM guardian) -{ - scm_c_issue_deprecation_warning - ("scm_guard is deprecated. Use scm_call_0 instead."); - - return scm_call_0 (guardian); -} - -SCM_DEFINE (scm_guardian_destroyed_p, "guardian-destroyed?", 1, 0, 0, - (SCM guardian), - "Return @code{#t} if @var{guardian} has been destroyed, otherwise @code{#f}.") -#define FUNC_NAME s_scm_guardian_destroyed_p -{ - scm_c_issue_deprecation_warning - ("'guardian-destroyed?' is deprecated."); - return SCM_BOOL_F; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_guardian_greedy_p, "guardian-greedy?", 1, 0, 0, - (SCM guardian), - "Return @code{#t} if @var{guardian} is a greedy guardian, otherwise @code{#f}.") -#define FUNC_NAME s_scm_guardian_greedy_p -{ - scm_c_issue_deprecation_warning - ("'guardian-greedy?' is deprecated."); - return SCM_BOOL_F; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_destroy_guardian_x, "destroy-guardian!", 1, 0, 0, - (SCM guardian), - "Destroys @var{guardian}, by making it impossible to put any more\n" - "objects in it or get any objects from it. It also unguards any\n" - "objects guarded by @var{guardian}.") -#define FUNC_NAME s_scm_destroy_guardian_x -{ - scm_c_issue_deprecation_warning - ("'destroy-guardian!' is deprecated and ineffective."); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -/* GC-related things. */ - -unsigned long scm_mallocated, scm_mtrigger; -size_t scm_max_segment_size; - -#if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST) -SCM -scm_map_free_list (void) -{ - return SCM_EOL; -} -#endif - -#if defined (GUILE_DEBUG_FREELIST) -SCM -scm_gc_set_debug_check_freelist_x (SCM flag) -{ - return SCM_UNSPECIFIED; -} -#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; -} - -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); -} - - - -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 - - - - - -SCM -scm_raequal (SCM ra0, SCM ra1) -{ - return scm_array_equal_p (ra0, ra1); -} - - - - - -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 - - - - - -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; -} - - - -/* 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); -} - - - -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); -} - -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); -} - - - -#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 */ - - - -/* {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 (not_found_proc != SCM_BOOL_F) - 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 - - - -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); -} - - - -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)); -} - - - void scm_i_init_deprecated () { - properties_whash = scm_make_weak_key_hash_table (SCM_UNDEFINED); - scm_struct_table = scm_make_hash_table (SCM_UNDEFINED); #include "libguile/deprecated.x" } diff --git a/libguile/deprecated.h b/libguile/deprecated.h index 6693c6c73..ddc97a8fe 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -31,118 +31,6 @@ #if (SCM_ENABLE_DEPRECATED == 1) -/* From eval.h: Macros for handling ilocs. These were deprecated in guile - * 1.7.0 on 2004-04-22. */ -#define SCM_IFRINC (0x00000100L) -#define SCM_ICDR (0x00080000L) -#define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \ - & (SCM_UNPACK (n) >> 8)) -#define SCM_IDIST(n) (SCM_UNPACK (n) >> 20) -#define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n)) - - -/* From tags.h: Macros to access internal symbol names of isyms. Deprecated - * in guile 1.7.0 on 2004-04-22. */ -SCM_API char *scm_isymnames[]; -#define SCM_ISYMNUM(n) 0 -#define SCM_ISYMCHARS(n) "#@" - - -/* From tags.h: Macro checking for two tc16 types that are allocated to differ - * only in the 's'-bit. Deprecated in guile 1.7.0 on 2003-09-21. */ -#define SCM_TYP16S(x) (0xfeff & SCM_CELL_TYPE (x)) - - -/* From numbers.h: Macros checking for types, but avoiding a redundant check - * for !SCM_IMP. These were deprecated in guile 1.7.0 on 2003-09-06. */ -#define SCM_SLOPPY_INEXACTP(x) (SCM_TYP16S (x) == scm_tc16_real) -#define SCM_SLOPPY_REALP(x) (SCM_TYP16 (x) == scm_tc16_real) -#define SCM_SLOPPY_COMPLEXP(x) (SCM_TYP16 (x) == scm_tc16_complex) - - -/* From structs.h: - Deprecated in Guile 1.9.5 on 2009-11-03. */ -#define scm_vtable_index_vtable scm_vtable_index_self -#define scm_vtable_index_printer scm_vtable_index_instance_printer -#define scm_struct_i_free scm_vtable_index_instance_finalize -#define scm_struct_i_flags scm_vtable_index_flags -#define SCM_STRUCTF_MASK ((scm_t_bits)-1) -#define SCM_SET_VTABLE_DESTRUCTOR(X, D) (SCM_STRUCT_DATA(x)[scm_struct_i_free]=(scm_t_bits)(D)) - -#define scm_substring_move_left_x scm_substring_move_x -#define scm_substring_move_right_x scm_substring_move_x - -#define scm_sizet size_t - -SCM_DEPRECATED SCM scm_wta (SCM arg, const char *pos, const char *s_subr); - -#define SCM_WNA 8 -#define SCM_OUTOFRANGE 10 -#define SCM_NALLOC 11 - -SCM_DEPRECATED void scm_register_module_xxx (char *module_name, void *init_func); -SCM_DEPRECATED SCM scm_registered_modules (void); -SCM_DEPRECATED SCM scm_clear_registered_modules (void); - -SCM_DEPRECATED SCM scm_protect_object (SCM obj); -SCM_DEPRECATED SCM scm_unprotect_object (SCM obj); - -#define SCM_SETAND_CAR(x, y) \ - (SCM_SETCAR ((x), SCM_PACK (SCM_UNPACK (SCM_CAR (x)) & (y)))) -#define SCM_SETOR_CAR(x, y)\ - (SCM_SETCAR ((x), SCM_PACK (SCM_UNPACK (SCM_CAR (x)) | (y)))) -#define SCM_SETAND_CDR(x, y)\ - (SCM_SETCDR ((x), SCM_PACK (SCM_UNPACK (SCM_CDR (x)) & (y)))) -#define SCM_SETOR_CDR(x, y)\ - (SCM_SETCDR ((x), SCM_PACK (SCM_UNPACK (SCM_CDR (x)) | (y)))) -#define SCM_FREEP(x) (0) -#define SCM_NFREEP(x) (1) -#define SCM_GCTYP16(x) SCM_TYP16 (x) -#define SCM_GCCDR(x) SCM_CDR (x) -SCM_DEPRECATED void scm_remember (SCM * ptr); - -SCM_DEPRECATED SCM scm_make_module (SCM name); -SCM_DEPRECATED SCM scm_ensure_user_module (SCM name); -SCM_DEPRECATED SCM scm_load_scheme_module (SCM name); - -#define scm_port scm_t_port -#define scm_ptob_descriptor scm_t_ptob_descriptor -#define scm_port_rw_active scm_t_port_rw_active - -SCM_DEPRECATED SCM scm_close_all_ports_except (SCM ports); - -#define scm_rstate scm_t_rstate -#define scm_rng scm_t_rng - -#define SCM_SLOPPY_CONSP(x) ((1 & SCM_CELL_TYPE (x)) == 0) -#define SCM_SLOPPY_NCONSP(x) (!SCM_SLOPPY_CONSP(x)) - -#define scm_tc7_ssymbol scm_tc7_symbol -#define scm_tc7_msymbol scm_tc7_symbol -#define scm_tcs_symbols scm_tc7_symbol - -SCM_DEPRECATED SCM scm_makstr (size_t len, int); -SCM_DEPRECATED SCM scm_makfromstr (const char *src, size_t len, int); - -SCM_DEPRECATED SCM scm_variable_set_name_hint (SCM var, SCM hint); -SCM_DEPRECATED SCM scm_builtin_variable (SCM name); - -SCM_DEPRECATED SCM scm_internal_with_fluids (SCM fluids, SCM vals, - SCM (*cproc)(void *), - void *cdata); - -SCM_DEPRECATED SCM scm_make_gsubr (const char *name, - int req, int opt, int rst, - scm_t_subr fcn); -SCM_DEPRECATED SCM scm_make_gsubr_with_generic (const char *name, - int req, - int opt, - int rst, - scm_t_subr fcn, - SCM *gf); - -SCM_DEPRECATED SCM scm_create_hook (const char* name, int n_args); - #define SCM_LIST0 SCM_EOL #define SCM_LIST1(e0) scm_cons ((e0), SCM_EOL) #define SCM_LIST2(e0, e1) scm_cons2 ((e0), (e1), SCM_EOL) @@ -161,625 +49,36 @@ SCM_DEPRECATED SCM scm_create_hook (const char* name, int n_args); scm_cons ((e0),\ SCM_LIST8 ((e1), (e2), (e3), (e4), (e5), (e6), (e7), (e8))) -#define scm_listify scm_list_n - -SCM_DEPRECATED SCM scm_sloppy_memq (SCM x, SCM lst); -SCM_DEPRECATED SCM scm_sloppy_memv (SCM x, SCM lst); -SCM_DEPRECATED SCM scm_sloppy_member (SCM x, SCM lst); - -SCM_DEPRECATED SCM scm_read_and_eval_x (SCM port); - -#define scm_subr_entry scm_t_subr_entry - -#define SCM_SUBR_DOC(x) SCM_BOOL_F - -SCM_DEPRECATED SCM scm_call_catching_errors (scm_t_subr thunk, - scm_t_subr err_filter, - void * closure); - -SCM_DEPRECATED long scm_make_smob_type_mfpe (char *name, size_t size, - SCM (*mark) (SCM), - size_t (*free) (SCM), - int (*print) (SCM, SCM, - scm_print_state*), - SCM (*equalp) (SCM, SCM)); - -SCM_DEPRECATED void scm_set_smob_mfpe (long tc, - SCM (*mark) (SCM), - size_t (*free) (SCM), - int (*print) (SCM, SCM, scm_print_state*), - SCM (*equalp) (SCM, SCM)); - -SCM_DEPRECATED size_t scm_smob_free (SCM obj); - -SCM_DEPRECATED SCM scm_strprint_obj (SCM obj); -SCM_DEPRECATED SCM scm_read_0str (char *expr); -SCM_DEPRECATED SCM scm_eval_0str (const char *expr); - -SCM_DEPRECATED char *scm_i_object_chars (SCM); - -#define SCM_CHARS(x) scm_i_object_chars(x) -#define SCM_UCHARS(x) ((unsigned char *)SCM_CHARS(x)) - -SCM_DEPRECATED long scm_i_object_length (SCM); - -#define SCM_LENGTH(x) scm_i_object_length(x) - -#define scm_strhash(str, len, n) (scm_string_hash ((str), (len)) % (n)) - -SCM_DEPRECATED SCM scm_sym2ovcell_soft (SCM sym, SCM obarray); -SCM_DEPRECATED SCM scm_sym2ovcell (SCM sym, SCM obarray); -SCM_DEPRECATED SCM scm_intern_obarray_soft (const char *name, size_t len, - SCM obarray, unsigned int softness); -SCM_DEPRECATED SCM scm_intern_obarray (const char *name, size_t len, SCM obarray); -SCM_DEPRECATED SCM scm_symbol_value0 (const char *name); - -SCM_DEPRECATED SCM scm_string_to_obarray_symbol (SCM o, SCM s, SCM softp); -SCM_DEPRECATED SCM scm_intern_symbol (SCM o, SCM s); -SCM_DEPRECATED SCM scm_unintern_symbol (SCM o, SCM s); -SCM_DEPRECATED SCM scm_symbol_binding (SCM o, SCM s); -#if 0 -/* This name has been reused for real uninterned symbols. */ -SCM_DEPRECATED SCM scm_symbol_interned_p (SCM o, SCM s); -#endif -SCM_DEPRECATED SCM scm_symbol_bound_p (SCM o, SCM s); -SCM_DEPRECATED SCM scm_symbol_set_x (SCM o, SCM s, SCM v); - -SCM_DEPRECATED SCM scm_gentemp (SCM prefix, SCM obarray); - -#define SCM_OPDIRP(x) (SCM_DIRP (x) && (SCM_DIR_OPEN_P (x))) -#define scm_fport scm_t_fport -#define scm_option scm_t_option -#define scm_srcprops scm_t_srcprops -#define scm_srcprops_chunk scm_t_srcprops_chunk -#define scm_array scm_t_array -#define scm_array_dim scm_t_array_dim -#define SCM_FUNC_NAME (scm_makfrom0str (FUNC_NAME)) - -#define SCM_WTA(pos, scm) \ - do { scm_wta (scm, (char *) pos, FUNC_NAME); } while (0) - -#define RETURN_SCM_WTA(pos, scm) \ - do { return scm_wta (scm, (char *) pos, FUNC_NAME); } while (0) - -#define SCM_VALIDATE_NUMBER_COPY(pos, z, cvar) \ - do { \ - if (SCM_I_INUMP (z)) \ - cvar = (double) SCM_I_INUM (z); \ - else if (SCM_REALP (z)) \ - cvar = SCM_REAL_VALUE (z); \ - else if (SCM_BIGP (z)) \ - cvar = scm_i_big2dbl (z); \ - else \ - { \ - cvar = 0.0; \ - SCM_WRONG_TYPE_ARG (pos, z); \ - } \ - } while (0) - -#define SCM_VALIDATE_NUMBER_DEF_COPY(pos, number, def, cvar) \ - do { \ - if (SCM_UNBNDP (number)) \ - cvar = def; \ - else \ - SCM_VALIDATE_NUMBER_COPY(pos, number, cvar); \ - } while (0) - -#define SCM_VALIDATE_OPDIR(pos, port) SCM_MAKE_VALIDATE (pos, port, OPDIRP) - -/* Deprecated because we can not safely cast a SCM* to a scm_t_bits* - */ - -#define SCM_CELL_WORD_LOC(x, n) ((scm_t_bits*)SCM_CELL_OBJECT_LOC((x),(n))) - -/* Users shouldn't know about INUMs. - */ - -SCM_DEPRECATED SCM scm_i_makinum (scm_t_signed_bits val); -SCM_DEPRECATED int scm_i_inump (SCM obj); -SCM_DEPRECATED scm_t_signed_bits scm_i_inum (SCM obj); - -#define SCM_MAKINUM(x) scm_i_makinum(x) -#define SCM_INUM(x) scm_i_inum(x) -#define SCM_INUMP(x) scm_i_inump(x) -#define SCM_NINUMP(x) (!SCM_INUMP(x)) - -#define SCM_VALIDATE_INUM(pos, k) SCM_MAKE_VALIDATE_MSG (pos, k, INUMP, "exact integer") - -#define SCM_VALIDATE_INUM_COPY(pos, k, cvar) \ - do { \ - SCM_ASSERT (SCM_I_INUMP (k), k, pos, FUNC_NAME); \ - cvar = SCM_I_INUM (k); \ - } while (0) - -#define SCM_VALIDATE_BIGINT(pos, k) SCM_MAKE_VALIDATE_MSG (pos, k, BIGP, "bignum") - -#define SCM_VALIDATE_INUM_MIN(pos, k, min) \ - do { \ - SCM_ASSERT (SCM_I_INUMP(k), k, pos, FUNC_NAME); \ - SCM_ASSERT_RANGE (pos, k, (SCM_I_INUM (k) >= min)); \ - } while (0) - -#define SCM_VALIDATE_INUM_MIN_COPY(pos, k, min, cvar) \ - do { \ - SCM_ASSERT (SCM_I_INUMP (k), k, pos, FUNC_NAME); \ - SCM_ASSERT_RANGE (pos, k, (SCM_I_INUM (k) >= min)); \ - cvar = SCM_INUM (k); \ - } while (0) - -#define SCM_VALIDATE_INUM_MIN_DEF_COPY(pos, k, min, default, cvar) \ - do { \ - if (SCM_UNBNDP (k)) \ - k = SCM_I_MAKINUM (default); \ - SCM_ASSERT (SCM_I_INUMP (k), k, pos, FUNC_NAME); \ - SCM_ASSERT_RANGE (pos, k, (SCM_I_INUM (k) >= min)); \ - cvar = SCM_INUM (k); \ - } while (0) - -#define SCM_VALIDATE_INUM_DEF(pos, k, default) \ - do { \ - if (SCM_UNBNDP (k)) \ - k = SCM_I_MAKINUM (default); \ - else SCM_ASSERT (SCM_I_INUMP (k), k, pos, FUNC_NAME); \ - } while (0) - -#define SCM_VALIDATE_INUM_DEF_COPY(pos, k, default, cvar) \ - do { \ - if (SCM_UNBNDP (k)) \ - { \ - k = SCM_I_MAKINUM (default); \ - cvar = default; \ - } \ - else \ - { \ - SCM_ASSERT (SCM_I_INUMP (k), k, pos, FUNC_NAME); \ - cvar = SCM_INUM (k); \ - } \ - } while (0) - -/* [low, high) */ -#define SCM_VALIDATE_INUM_RANGE(pos, k, low, high) \ - do { SCM_ASSERT(SCM_I_INUMP(k), k, pos, FUNC_NAME); \ - SCM_ASSERT_RANGE(pos, k, \ - (SCM_I_INUM (k) >= low && \ - SCM_I_INUM (k) < high)); \ - } while (0) - -#define SCM_VALIDATE_INUM_RANGE_COPY(pos, k, low, high, cvar) \ - do { \ - SCM_ASSERT (SCM_INUMP (k), k, pos, FUNC_NAME); \ - SCM_ASSERT_RANGE (pos, k, low <= SCM_INUM (k) && SCM_INUM (k) < high); \ - cvar = SCM_INUM (k); \ - } while (0) - -#define SCM_STRING_COERCE_0TERMINATION_X(x) (x) - -/* XXX - buggy interface, STR might not be large enough. - - Converts the given Scheme string OBJ into a C string, containing a copy - of OBJ's content with a trailing null byte. If LENP is non-NULL, set - *LENP to the string's length. - - When STR is non-NULL it receives the copy and is returned by the function, - otherwise new memory is allocated and the caller is responsible for - freeing it via free(). If out of memory, NULL is returned. - - Note that Scheme strings may contain arbitrary data, including null - characters. This means that null termination is not a reliable way to - determine the length of the returned value. However, the function always - copies the complete contents of OBJ, and sets *LENP to the length of the - scheme string (if LENP is non-null). -*/ -SCM_DEPRECATED char *scm_c_string2str (SCM obj, char *str, size_t *lenp); - -/* XXX - buggy interface, you don't know how many bytes have been copied. - - Copy LEN characters at START from the Scheme string OBJ to memory - at STR. START is an index into OBJ; zero means the beginning of - the string. STR has already been allocated by the caller. - - If START + LEN is off the end of OBJ, silently truncate the source - region to fit the string. If truncation occurs, the corresponding - area of STR is left unchanged. -*/ -SCM_DEPRECATED char *scm_c_substring2str (SCM obj, char *str, size_t start, size_t len); - -SCM_DEPRECATED char *scm_c_symbol2str (SCM obj, char *str, size_t *lenp); - -/* Deprecated because the names belong to what is now - scm_truncate_number and scm_round_number. -*/ -SCM_DEPRECATED double scm_truncate (double x); -SCM_DEPRECATED double scm_round (double x); -/* Deprecated, use scm_expt */ -SCM_DEPRECATED SCM scm_sys_expt (SCM x, SCM y); - -/* if your platform doesn't have asinh et al */ -SCM_API double scm_asinh (double x); -SCM_API double scm_acosh (double x); -SCM_API double scm_atanh (double x); -SCM_API SCM scm_sys_atan2 (SCM z1, SCM z2); - -/* Deprecated because we don't want people to access the internal - representation of strings directly. -*/ - -#define SCM_VALIDATE_STRING_COPY(pos, str, cvar) \ - do { \ - SCM_ASSERT (SCM_STRINGP (str), str, pos, FUNC_NAME); \ - cvar = SCM_STRING_CHARS(str); \ - } while (0) - -/* validate a string and optional start/end arguments which default to - 0/string-len. this is unrelated to the old shared substring - support, so please do not deprecate it :) */ -#define SCM_VALIDATE_SUBSTRING_SPEC_COPY(pos_str, str, c_str, \ - pos_start, start, c_start,\ - pos_end, end, c_end) \ - do {\ - SCM_VALIDATE_STRING_COPY (pos_str, str, c_str);\ - c_start = SCM_UNBNDP(start)? 0 : scm_to_size_t (start);\ - c_end = SCM_UNBNDP(end)? SCM_STRING_LENGTH(str) : scm_to_size_t (end);\ - SCM_ASSERT_RANGE (pos_start, start,\ - 0 <= c_start \ - && (size_t) c_start <= SCM_STRING_LENGTH (str));\ - SCM_ASSERT_RANGE (pos_end, end,\ - c_start <= c_end \ - && (size_t) c_end <= SCM_STRING_LENGTH (str));\ - } while (0) - -/* Deprecated because we don't want people to access the internals of - symbols directly. -*/ - -SCM_DEPRECATED char *scm_i_deprecated_symbol_chars (SCM sym); -SCM_DEPRECATED size_t scm_i_deprecated_symbol_length (SCM sym); - -#define SCM_SYMBOL_CHARS(x) scm_i_deprecated_symbol_chars(x) -#define SCM_SYMBOL_LENGTH(x) scm_i_deprecated_symbol_length(x) - -/* Deprecated because the macros used to evaluate the arguments more - than once and because the symbol of a keyword now has no dash. -*/ - -SCM_DEPRECATED int scm_i_keywordp (SCM obj); -SCM_DEPRECATED SCM scm_i_keywordsym (SCM keyword); - -#define SCM_KEYWORDP(x) scm_i_keywordp(x) -#define SCM_KEYWORDSYM(x) scm_i_keywordsym(x) - -/* Deprecated because we don't want to hand out unprotected pointers - to arrays, vectors, etc. */ - -#define SCM_VECTOR_MAX_LENGTH ((1L << 24) - 1) - -SCM_DEPRECATED int scm_i_vectorp (SCM x); -SCM_DEPRECATED unsigned long scm_i_vector_length (SCM x); -SCM_DEPRECATED const SCM *scm_i_velts (SCM x); -SCM_DEPRECATED SCM *scm_i_writable_velts (SCM x); -SCM_DEPRECATED SCM scm_i_vector_ref (SCM x, size_t idx); -SCM_DEPRECATED void scm_i_vector_set (SCM x, size_t idx, SCM val); -SCM_DEPRECATED SCM scm_vector_equal_p (SCM x, SCM y); - -#define SCM_VECTORP(x) scm_i_vectorp(x) -#define SCM_VECTOR_LENGTH(x) scm_i_vector_length(x) -#define SCM_VELTS(x) scm_i_velts(x) -#define SCM_WRITABLE_VELTS(x) scm_i_writable_velts(x) -#define SCM_VECTOR_REF(x,y) scm_i_vector_ref(x,y) -#define SCM_VECTOR_SET(x,y,z) scm_i_vector_set(x,y,z) - -typedef scm_i_t_array scm_t_array; - -SCM_DEPRECATED int scm_i_arrayp (SCM a); -SCM_DEPRECATED size_t scm_i_array_ndim (SCM a); -SCM_DEPRECATED int scm_i_array_contp (SCM a); -SCM_DEPRECATED scm_t_array *scm_i_array_mem (SCM a); -SCM_DEPRECATED SCM scm_i_array_v (SCM a); -SCM_DEPRECATED size_t scm_i_array_base (SCM a); -SCM_DEPRECATED scm_t_array_dim *scm_i_array_dims (SCM a); - -#define SCM_ARRAYP(a) scm_i_arrayp(a) -#define SCM_ARRAY_NDIM(a) scm_i_array_ndim(a) -#define SCM_ARRAY_CONTP(a) scm_i_array_contp(a) -#define SCM_ARRAY_MEM(a) scm_i_array_mem(a) -#define SCM_ARRAY_V(a) scm_i_array_v(a) -#define SCM_ARRAY_BASE(a) scm_i_array_base(a) -#define SCM_ARRAY_DIMS(a) scm_i_array_dims(a) - -SCM_DEPRECATED SCM scm_uniform_vector_read_x (SCM v, SCM port_or_fd, - SCM start, SCM end); -SCM_DEPRECATED SCM scm_uniform_vector_write (SCM v, SCM port_or_fd, - SCM start, SCM end); -SCM_DEPRECATED SCM scm_uniform_array_read_x (SCM ra, SCM port_or_fd, - SCM start, SCM end); -SCM_DEPRECATED SCM scm_uniform_array_write (SCM v, SCM port_or_fd, - SCM start, SCM end); - -/* Deprecated because they should not be lvalues and we want people to - use the official interfaces. - */ - -#define scm_cur_inp scm_i_cur_inp () -#define scm_cur_outp scm_i_cur_outp () -#define scm_cur_errp scm_i_cur_errp () -#define scm_cur_loadp scm_i_cur_loadp () -#define scm_progargs scm_i_progargs () -#define scm_dynwinds scm_i_deprecated_dynwinds () -#define scm_stack_base scm_i_stack_base () - -SCM_DEPRECATED SCM scm_i_cur_inp (void); -SCM_DEPRECATED SCM scm_i_cur_outp (void); -SCM_DEPRECATED SCM scm_i_cur_errp (void); -SCM_DEPRECATED SCM scm_i_cur_loadp (void); -SCM_DEPRECATED SCM scm_i_progargs (void); -SCM_DEPRECATED SCM scm_i_deprecated_dynwinds (void); -SCM_DEPRECATED SCM_STACKITEM *scm_i_stack_base (void); - -/* Deprecated because it evaluates its argument twice. - */ -#define SCM_FLUIDP(x) scm_i_fluidp (x) -SCM_DEPRECATED int scm_i_fluidp (SCM x); - -/* Deprecated in Guile 1.9.5 on 2009-11-15 because these are IPv4-only - functions which are deprecated upstream. */ - -SCM_DEPRECATED SCM scm_inet_aton (SCM address); -SCM_DEPRECATED SCM scm_inet_ntoa (SCM inetid); - -/* In the old days, SCM_CRITICAL_SECTION_START stopped signal handlers - from running, since in those days the handler directly ran scheme - code, and that had to be avoided when the heap was not in a - consistent state etc. And since the scheme code could do a stack - swapping new continuation etc, signals had to be deferred around - various C library functions which were not safe or not known to be - safe to swap away, which was a lot of stuff. - - These days signals are implemented with asyncs and don't directly - run scheme code in the handler, but hold it until an SCM_TICK etc - where it will be safe. This means interrupt protection is not - needed and SCM_CRITICAL_SECTION_START / SCM_CRITICAL_SECTION_END is - something of an anachronism. - - What past SCM_CRITICAL_SECTION_START usage also did though was - indicate code that was not reentrant, ie. could not be reentered by - signal handler code. The present definitions are a mutex lock, - affording that reentrancy protection against the new guile 1.8 - free-running posix threads. - - One big problem with the present defintions though is that code which - throws an error from within a DEFER/ALLOW region will leave the - defer_mutex locked and hence hang other threads that attempt to enter a - similar DEFER/ALLOW region. -*/ - -SCM_DEPRECATED void scm_i_defer_ints_etc (void); -#define SCM_DEFER_INTS scm_i_defer_ints_etc () -#define SCM_ALLOW_INTS scm_i_defer_ints_etc () -#define SCM_REDEFER_INTS scm_i_defer_ints_etc () -#define SCM_REALLOW_INTS scm_i_defer_ints_etc () - -/* In the old days (pre-1.8), this macro was sometimes used as an lvalue as - in "scm_mask_ints = 1" to block async execution. It no longer works. */ -#define scm_mask_ints (scm_i_mask_ints ()) - -SCM_DEPRECATED int scm_i_mask_ints (void); - -/* Deprecated since they are unnecessary and had not been documented. - */ -SCM_DEPRECATED SCM scm_guard (SCM guardian, SCM obj, int throw_p); -SCM_DEPRECATED SCM scm_get_one_zombie (SCM guardian); - -/* Deprecated since guardians no longer have these special features. - */ -SCM_DEPRECATED SCM scm_destroy_guardian_x (SCM guardian); -SCM_DEPRECATED SCM scm_guardian_greedy_p (SCM guardian); -SCM_DEPRECATED SCM scm_guardian_destroyed_p (SCM guardian); - - -/* GC-related things deprecated with the move to BDW-GC starting from 1.9.3 - (2009-09-15). */ - -SCM_DEPRECATED unsigned long scm_mallocated; -SCM_DEPRECATED unsigned long scm_mtrigger; - -SCM_DEPRECATED size_t scm_max_segment_size; - -#if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST) -SCM_DEPRECATED SCM scm_map_free_list (void); -#endif - -#if defined (GUILE_DEBUG_FREELIST) -SCM_DEPRECATED SCM scm_gc_set_debug_check_freelist_x (SCM flag); -#endif - - - -/* Deprecated 2009-11-27, scm_call_N is sufficient */ -SCM_DEPRECATED scm_t_trampoline_0 scm_trampoline_0 (SCM proc); -SCM_DEPRECATED scm_t_trampoline_1 scm_trampoline_1 (SCM proc); -SCM_DEPRECATED scm_t_trampoline_2 scm_trampoline_2 (SCM proc); - - - -/* Deprecated 2009-12-06, use the procedures instead */ -#define SCM_PROCEDURE_WITH_SETTER_P(obj) (scm_is_true (scm_procedure_with_setter_p (obj))) -#define SCM_PROCEDURE(obj) SCM_STRUCT_PROCEDURE (obj, 0) -#define SCM_SETTER(obj) SCM_STRUCT_SETTER (obj, 1) - - - -/* Deprecated 2010-01-05, use SCM_PRIMITIVE_P instead */ -SCM_DEPRECATED int scm_i_subr_p (SCM x); -#define scm_subr_p(x) (scm_i_subr_p (x)) - - - -/* Deprecated 2010-01-31, use with-throw-handler instead */ -SCM_DEPRECATED SCM scm_lazy_catch (SCM tag, SCM thunk, SCM handler); -SCM_DEPRECATED SCM scm_internal_lazy_catch (SCM tag, - scm_t_catch_body body, - void *body_data, - scm_t_catch_handler handler, - void *handler_data); - - - -/* Deprecated 2010-03-31, use array-equal? instead */ -SCM_DEPRECATED SCM scm_raequal (SCM ra0, SCM ra1); - -/* Deprecated 2010-04-01, use the dynamic FFI instead */ -SCM_DEPRECATED SCM scm_dynamic_args_call (SCM symb, SCM dobj, SCM args); - -/* Deprecated 2010-05-12, no replacement */ -SCM_DEPRECATED int scm_badargsp (SCM formals, SCM args); - -/* Deprecated 2010-06-19, use call-with-error-handling instead */ -SCM_DEPRECATED SCM scm_internal_stack_catch (SCM tag, - scm_t_catch_body body, - void *body_data, - scm_t_catch_handler handler, - void *handler_data); - - - -/* These functions were "discouraged" in 1.8, and now are deprecated. */ - -/* scm_to_int, scm_from_int are the official functions to do the job, - but there is nothing wrong with using scm_num2int, etc. - - These could be trivially defined via macros, but we leave them as - functions since existing code may take their addresses. -*/ - -SCM_DEPRECATED SCM scm_short2num (short n); -SCM_DEPRECATED SCM scm_ushort2num (unsigned short n); -SCM_DEPRECATED SCM scm_int2num (int n); -SCM_DEPRECATED SCM scm_uint2num (unsigned int n); -SCM_DEPRECATED SCM scm_long2num (long n); -SCM_DEPRECATED SCM scm_ulong2num (unsigned long n); -SCM_DEPRECATED SCM scm_size2num (size_t n); -SCM_DEPRECATED SCM scm_ptrdiff2num (scm_t_ptrdiff n); -SCM_DEPRECATED short scm_num2short (SCM num, unsigned long int pos, - const char *s_caller); -SCM_DEPRECATED unsigned short scm_num2ushort (SCM num, unsigned long int pos, - const char *s_caller); -SCM_DEPRECATED int scm_num2int (SCM num, unsigned long int pos, - const char *s_caller); -SCM_DEPRECATED unsigned int scm_num2uint (SCM num, unsigned long int pos, - const char *s_caller); -SCM_DEPRECATED long scm_num2long (SCM num, unsigned long int pos, - const char *s_caller); -SCM_DEPRECATED unsigned long scm_num2ulong (SCM num, unsigned long int pos, - const char *s_caller); -SCM_DEPRECATED scm_t_ptrdiff scm_num2ptrdiff (SCM num, unsigned long int pos, - const char *s_caller); -SCM_DEPRECATED size_t scm_num2size (SCM num, unsigned long int pos, - const char *s_caller); -#if SCM_SIZEOF_LONG_LONG != 0 -SCM_DEPRECATED SCM scm_long_long2num (long long sl); -SCM_DEPRECATED SCM scm_ulong_long2num (unsigned long long sl); -SCM_DEPRECATED long long scm_num2long_long (SCM num, unsigned long int pos, - const char *s_caller); -SCM_DEPRECATED unsigned long long scm_num2ulong_long (SCM num, unsigned long int pos, - const char *s_caller); -#endif - -SCM_DEPRECATED SCM scm_make_real (double x); -SCM_DEPRECATED double scm_num2dbl (SCM a, const char * why); -SCM_DEPRECATED SCM scm_float2num (float n); -SCM_DEPRECATED SCM scm_double2num (double n); - -/* The next two are implemented in numbers.c since they use features - only available there. -*/ -SCM_DEPRECATED float scm_num2float (SCM num, unsigned long int pos, - const char *s_caller); -SCM_DEPRECATED double scm_num2double (SCM num, unsigned long int pos, - const char *s_caller); - -SCM_DEPRECATED SCM scm_make_complex (double x, double y); - -/* Discouraged because they don't make the encoding explicit. - */ - -SCM_DEPRECATED SCM scm_mem2symbol (const char *mem, size_t len); -SCM_DEPRECATED SCM scm_mem2uninterned_symbol (const char *mem, size_t len); -SCM_DEPRECATED SCM scm_str2symbol (const char *str); - -SCM_DEPRECATED SCM scm_take_str (char *s, size_t len); -SCM_DEPRECATED SCM scm_take0str (char *s); -SCM_DEPRECATED SCM scm_mem2string (const char *src, size_t len); -SCM_DEPRECATED SCM scm_str2string (const char *src); -SCM_DEPRECATED SCM scm_makfrom0str (const char *src); -SCM_DEPRECATED SCM scm_makfrom0str_opt (const char *src); - -/* Discouraged because scm_c_make_string has a better name and is more - consistent with make-string. - */ -SCM_DEPRECATED SCM scm_allocate_string (size_t len); - -/* Discouraged because they are just strange. - */ - -SCM_DEPRECATED SCM scm_make_keyword_from_dash_symbol (SCM symbol); -SCM_DEPRECATED SCM scm_keyword_dash_symbol (SCM keyword); - -/* Discouraged because it does not state what encoding S is in. - */ - -SCM_DEPRECATED SCM scm_c_make_keyword (const char *s); - -SCM_DEPRECATED unsigned int scm_thread_sleep (unsigned int); -SCM_DEPRECATED unsigned long scm_thread_usleep (unsigned long); -SCM_DEPRECATED int scm_internal_select (int fds, - SELECT_TYPE *rfds, - SELECT_TYPE *wfds, - SELECT_TYPE *efds, - struct timeval *timeout); - -/* Deprecated because the cuserid call is deprecated. - */ -SCM_DEPRECATED SCM scm_cuserid (void); - - - -/* Deprecated because it's yet another property interface. - */ -SCM_DEPRECATED SCM scm_primitive_make_property (SCM not_found_proc); -SCM_DEPRECATED SCM scm_primitive_property_ref (SCM prop, SCM obj); -SCM_DEPRECATED SCM scm_primitive_property_set_x (SCM prop, SCM obj, SCM val); -SCM_DEPRECATED SCM scm_primitive_property_del_x (SCM prop, SCM obj); - - - -/* {The old whash table interface} - * Deprecated, as the hash table interface is sufficient, and accessing - * handles of weak hash tables is no longer supported. - */ - -#define scm_whash_handle SCM - -SCM_DEPRECATED SCM scm_whash_get_handle (SCM whash, SCM key); -SCM_DEPRECATED int SCM_WHASHFOUNDP (SCM h); -SCM_DEPRECATED SCM SCM_WHASHREF (SCM whash, SCM handle); -SCM_DEPRECATED void SCM_WHASHSET (SCM whash, SCM handle, SCM obj); -SCM_DEPRECATED SCM scm_whash_create_handle (SCM whash, SCM key); -SCM_DEPRECATED SCM scm_whash_lookup (SCM whash, SCM obj); -SCM_DEPRECATED void scm_whash_insert (SCM whash, SCM key, SCM obj); - - - - -/* No need for a table for names, and the struct->class mapping is - maintained by GOOPS now. */ -#define SCM_STRUCT_TABLE_NAME(X) SCM_CAR (X) -#define SCM_SET_STRUCT_TABLE_NAME(X, NAME) SCM_SETCAR (X, NAME) -#define SCM_STRUCT_TABLE_CLASS(X) SCM_CDR (X) -#define SCM_SET_STRUCT_TABLE_CLASS(X, CLASS) SCM_SETCDR (X, CLASS) - -SCM_DEPRECATED SCM scm_struct_table; -SCM_DEPRECATED SCM scm_struct_create_handle (SCM obj); - +#define SCM_OPDIRP SCM_OPDIRP__GONE__REPLACE_WITH__SCM_DIRP_and_SCM_DIR_OPEN_P +#define SCM_PROCEDURE SCM_PROCEDURE__GONE__REPLACE_WITH__scm_procedure +#define SCM_PROCEDURE_WITH_SETTER_P SCM_PROCEDURE_WITH_SETTER_P__GONE__REPLACE_WITH__scm_is_true__scm_procedure_with_setter_p +#define SCM_SETTER SCM_SETTER__GONE__REPLACE_WITH__scm_setter +#define SCM_VALIDATE_NUMBER_COPY SCM_VALIDATE_NUMBER_COPY__GONE__REPLACE_WITH__SCM_VALIDATE_DOUBLE_COPY +#define SCM_VALIDATE_NUMBER_DEF_COPY SCM_VALIDATE_NUMBER_DEF_COPY__GONE__REPLACE_WITH__SCM_UNBNDP_and_SCM_VALIDATE_DOUBLE_COPY +#define SCM_VALIDATE_OPDIR SCM_VALIDATE_OPDIR__GONE +#define SCM_VALIDATE_STRING_COPY SCM_VALIDATE_STRING_COPY__GONE +#define SCM_VALIDATE_SUBSTRING_SPEC_COPY SCM_VALIDATE_SUBSTRING_SPEC_COPY__GONE +#define scm_array scm_array__GONE__REPLACE_WITH__scm_t_array +#define scm_array_dim scm_array_dim__GONE__REPLACE_WITH__scm_t_array_dim +#define scm_fport scm_fport__GONE__REPLACE_WITH__scm_t_fport +#define scm_listify scm_listify__GONE__REPLACE_WITH__scm_list_n +#define scm_option scm_option__GONE__REPLACE_WITH__scm_t_option +#define scm_port scm_port__GONE__REPLACE_WITH__scm_t_port +#define scm_port_rw_active scm_port_rw_active__GONE__REPLACE_WITH__scm_t_port_rw_active +#define scm_ptob_descriptor scm_ptob_descriptor__GONE__REPLACE_WITH__scm_t_ptob_descriptor +#define scm_rng scm_rng__GONE__REPLACE_WITH__scm_t_rng +#define scm_rstate scm_rstate__GONE__REPLACE_WITH__scm_t_rstate +#define scm_sizet scm_sizet__GONE__REPLACE_WITH__size_t +#define scm_srcprops scm_srcprops__GONE__REPLACE_WITH__scm_t_srcprops +#define scm_srcprops_chunk scm_srcprops_chunk__GONE__REPLACE_WITH__scm_t_srcprops_chunk +#define scm_struct_i_flags scm_struct_i_flags__GONE__REPLACE_WITH__scm_vtable_index_flags +#define scm_struct_i_free scm_struct_i_free__GONE__REPLACE_WITH__scm_vtable_index_instance_finalize +#define scm_subr_entry scm_subr_entry__GONE__REPLACE_WITH__scm_t_subr_entry +#define scm_substring_move_left_x scm_substring_move_left_x__GONE__REPLACE_WITH__scm_substring_move_x +#define scm_substring_move_right_x scm_substring_move_right_x__GONE__REPLACE_WITH__scm_substring_move_x +#define scm_vtable_index_printer scm_vtable_index_printer__GONE__REPLACE_WITH__scm_vtable_index_instance_printer +#define scm_vtable_index_vtable scm_vtable_index_vtable__GONE__REPLACE_WITH__scm_vtable_index_self +typedef scm_i_t_array scm_i_t_array__GONE__REPLACE_WITH__scm_t_array; diff --git a/libguile/evalext.h b/libguile/evalext.h index fc3f1e617..7718ec621 100644 --- a/libguile/evalext.h +++ b/libguile/evalext.h @@ -3,7 +3,7 @@ #ifndef SCM_EVALEXT_H #define SCM_EVALEXT_H -/* Copyright (C) 1998,1999,2000, 2003, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1998,1999,2000, 2003, 2006, 2008, 2011 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 @@ -31,12 +31,6 @@ SCM_API SCM scm_defined_p (SCM sym, SCM env); SCM_API SCM scm_self_evaluating_p (SCM obj); SCM_INTERNAL void scm_init_evalext (void); -#if (SCM_ENABLE_DEPRECATED == 1) - -#define scm_definedp scm_defined_p - -#endif - #endif /* SCM_EVALEXT_H */ /* diff --git a/libguile/gc-malloc.c b/libguile/gc-malloc.c index 4f77f65dd..839154a46 100644 --- a/libguile/gc-malloc.c +++ b/libguile/gc-malloc.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2008, 2009, 2010 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2008, 2009, 2010, 2011 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 @@ -237,106 +237,3 @@ scm_gc_strdup (const char *str, const char *what) { return scm_gc_strndup (str, strlen (str), what); } - -#if SCM_ENABLE_DEPRECATED == 1 - -/* {Deprecated front end to malloc} - * - * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc, - * scm_done_free - * - * These functions provide services comparable to malloc, realloc, and - * free. - * - * There has been a fair amount of confusion around the use of these functions; - * see "Memory Blocks" in the manual. They are totally unnecessary in 2.0 given - * the Boehm GC. - */ - -void * -scm_must_malloc (size_t size, const char *what) -{ - scm_c_issue_deprecation_warning - ("scm_must_malloc is deprecated. " - "Use scm_gc_malloc and scm_gc_free instead."); - - return scm_gc_malloc (size, what); -} - -void * -scm_must_realloc (void *where, - size_t old_size, - size_t size, - const char *what) -{ - scm_c_issue_deprecation_warning - ("scm_must_realloc is deprecated. " - "Use scm_gc_realloc and scm_gc_free instead."); - - return scm_gc_realloc (where, old_size, size, what); -} - -char * -scm_must_strndup (const char *str, size_t length) -{ - scm_c_issue_deprecation_warning - ("scm_must_strndup is deprecated. " - "Use scm_gc_strndup and scm_gc_free instead."); - - return scm_gc_strndup (str, length, "string"); -} - -char * -scm_must_strdup (const char *str) -{ - scm_c_issue_deprecation_warning - ("scm_must_strdup is deprecated. " - "Use scm_gc_strdup and scm_gc_free instead."); - - return scm_gc_strdup (str, "string"); -} - -void -scm_must_free (void *obj) -#define FUNC_NAME "scm_must_free" -{ - scm_c_issue_deprecation_warning - ("scm_must_free is deprecated. " - "Use scm_gc_malloc and scm_gc_free instead."); - -#ifdef GUILE_DEBUG_MALLOC - scm_malloc_unregister (obj); -#endif - - GC_FREE (obj); -} -#undef FUNC_NAME - - -void -scm_done_malloc (long size) -{ - scm_c_issue_deprecation_warning - ("scm_done_malloc is deprecated. " - "Use scm_gc_register_collectable_memory instead."); - - if (size >= 0) - scm_gc_register_collectable_memory (NULL, size, "foreign mallocs"); - else - scm_gc_unregister_collectable_memory (NULL, -size, "foreign mallocs"); -} - -void -scm_done_free (long size) -{ - scm_c_issue_deprecation_warning - ("scm_done_free is deprecated. " - "Use scm_gc_unregister_collectable_memory instead."); - - if (size >= 0) - scm_gc_unregister_collectable_memory (NULL, size, "foreign mallocs"); - else - scm_gc_register_collectable_memory (NULL, -size, "foreign mallocs"); -} - -#endif /* SCM_ENABLE_DEPRECATED == 1 */ diff --git a/libguile/gc.h b/libguile/gc.h index 104fb0bb3..2e2fc1fa2 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -3,7 +3,7 @@ #ifndef SCM_GC_H #define SCM_GC_H -/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011 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 @@ -138,20 +138,6 @@ void *scm_ia64_ar_bsp (const void *); -#if (SCM_ENABLE_DEPRECATED == 1) -SCM_DEPRECATED size_t scm_default_init_heap_size_1; -SCM_DEPRECATED int scm_default_min_yield_1; -SCM_DEPRECATED size_t scm_default_init_heap_size_2; -SCM_DEPRECATED int scm_default_min_yield_2; -SCM_DEPRECATED size_t scm_default_max_segment_size; -#else -#define scm_default_init_heap_size_1 deprecated -#define scm_default_min_yield_1 deprecated -#define scm_default_init_heap_size_2 deprecated -#define scm_default_min_yield_2 deprecated -#define scm_default_max_segment_size deprecated -#endif - SCM_API unsigned long scm_gc_ports_collected; SCM_API SCM scm_after_gc_hook; @@ -247,28 +233,6 @@ SCM_INTERNAL void scm_storage_prehistory (void); SCM_INTERNAL void scm_init_gc_protect_object (void); SCM_INTERNAL void scm_init_gc (void); -#if SCM_ENABLE_DEPRECATED == 1 - -SCM_DEPRECATED SCM scm_deprecated_newcell (void); -SCM_DEPRECATED SCM scm_deprecated_newcell2 (void); - -#define SCM_NEWCELL(_into) \ - do { _into = scm_deprecated_newcell (); } while (0) -#define SCM_NEWCELL2(_into) \ - do { _into = scm_deprecated_newcell2 (); } while (0) - -SCM_DEPRECATED void * scm_must_malloc (size_t len, const char *what); -SCM_DEPRECATED void * scm_must_realloc (void *where, - size_t olen, size_t len, - const char *what); -SCM_DEPRECATED char *scm_must_strdup (const char *str); -SCM_DEPRECATED char *scm_must_strndup (const char *str, size_t n); -SCM_DEPRECATED void scm_done_malloc (long size); -SCM_DEPRECATED void scm_done_free (long size); -SCM_DEPRECATED void scm_must_free (void *obj); - -#endif - #endif /* SCM_GC_H */ /* diff --git a/libguile/gen-scmconfig.c b/libguile/gen-scmconfig.c index 176f25c02..1d38eeacc 100644 --- a/libguile/gen-scmconfig.c +++ b/libguile/gen-scmconfig.c @@ -383,15 +383,6 @@ main (int argc, char *argv[]) #endif pf ("\n"); - pf ("#if SCM_ENABLE_DEPRECATED == 1\n" - "# define USE_THREADS 1 /* always true now */\n" - "# define GUILE_ISELECT 1 /* always true now */\n" - "# define READER_EXTENSIONS 1 /* always true now */\n" - "# define DEBUG_EXTENSIONS 1 /* always true now */\n" - "# define DYNAMIC_LINKING 1 /* always true now */\n" - "#endif\n"); - printf ("\n"); - pf ("#define SCM_HAVE_ARRAYS 1 /* always true now */\n"); pf ("\n"); diff --git a/libguile/numbers.c b/libguile/numbers.c index fe510a195..7e0511918 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -9288,46 +9288,6 @@ scm_from_double (double val) return z; } -#if SCM_ENABLE_DEPRECATED == 1 - -float -scm_num2float (SCM num, unsigned long pos, const char *s_caller) -{ - scm_c_issue_deprecation_warning - ("`scm_num2float' is deprecated. Use scm_to_double instead."); - - if (SCM_BIGP (num)) - { - float res = mpz_get_d (SCM_I_BIG_MPZ (num)); - if (!isinf (res)) - return res; - else - scm_out_of_range (NULL, num); - } - else - return scm_to_double (num); -} - -double -scm_num2double (SCM num, unsigned long pos, const char *s_caller) -{ - scm_c_issue_deprecation_warning - ("`scm_num2double' is deprecated. Use scm_to_double instead."); - - if (SCM_BIGP (num)) - { - double res = mpz_get_d (SCM_I_BIG_MPZ (num)); - if (!isinf (res)) - return res; - else - scm_out_of_range (NULL, num); - } - else - return scm_to_double (num); -} - -#endif - int scm_is_complex (SCM val) { diff --git a/libguile/ports.c b/libguile/ports.c index 926149bf9..858c3dd54 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -621,29 +621,6 @@ scm_new_port_table_entry (scm_t_bits tag) } #undef FUNC_NAME -#if SCM_ENABLE_DEPRECATED==1 -scm_t_port * -scm_add_to_port_table (SCM port) -{ - SCM z; - scm_t_port * pt; - - scm_c_issue_deprecation_warning ("scm_add_to_port_table is deprecated."); - - scm_i_pthread_mutex_lock (&scm_i_port_table_mutex); - z = scm_new_port_table_entry (scm_tc7_port); - pt = SCM_PTAB_ENTRY(z); - pt->port = port; - SCM_SETCAR (z, SCM_EOL); - SCM_SETCDR (z, SCM_EOL); - SCM_SETPTAB_ENTRY (port, pt); - scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex); - - return pt; -} -#endif - - /* Remove a port from the table and destroy it. */ static void diff --git a/libguile/ports.h b/libguile/ports.h index 6a669b660..80da9a02f 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -316,10 +316,6 @@ SCM_API SCM scm_void_port (char * mode_str); SCM_API SCM scm_sys_make_void_port (SCM mode); SCM_INTERNAL void scm_init_ports (void); -#if SCM_ENABLE_DEPRECATED==1 -SCM_DEPRECATED scm_t_port * scm_add_to_port_table (SCM port); -#endif - #ifdef GUILE_DEBUG SCM_API SCM scm_pt_size (void); SCM_API SCM scm_pt_member (SCM member); diff --git a/libguile/procprop.c b/libguile/procprop.c index 2263d283a..39f573700 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008, 2009, 2010 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008, 2009, 2010, 2011 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 @@ -22,13 +22,9 @@ # include #endif -#define SCM_BUILDING_DEPRECATED_CODE - #include "libguile/_scm.h" #include "libguile/alist.h" -#include "libguile/deprecation.h" -#include "libguile/deprecated.h" #include "libguile/eval.h" #include "libguile/procs.h" #include "libguile/gsubr.h" @@ -43,9 +39,6 @@ SCM_GLOBAL_SYMBOL (scm_sym_system_procedure, "system-procedure"); -#if (SCM_ENABLE_DEPRECATED == 1) -SCM_GLOBAL_SYMBOL (scm_sym_arity, "arity"); -#endif SCM_GLOBAL_SYMBOL (scm_sym_name, "name"); static SCM overrides; @@ -123,10 +116,6 @@ SCM_DEFINE (scm_procedure_properties, "procedure-properties", 1, 0, 0, ret = SCM_EOL; } -#if (SCM_ENABLE_DEPRECATED == 1) - ret = scm_acons (scm_sym_arity, scm_procedure_minimum_arity (proc), ret); -#endif - return ret; } #undef FUNC_NAME @@ -138,11 +127,6 @@ SCM_DEFINE (scm_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0 { SCM_VALIDATE_PROC (1, proc); -#if (SCM_ENABLE_DEPRECATED == 1) - if (scm_assq (alist, scm_sym_arity)) - SCM_MISC_ERROR ("arity is a read-only property", SCM_EOL); -#endif - scm_i_pthread_mutex_lock (&overrides_lock); scm_hashq_set_x (overrides, proc, alist); scm_i_pthread_mutex_unlock (&overrides_lock); @@ -158,13 +142,6 @@ SCM_DEFINE (scm_procedure_property, "procedure-property", 2, 0, 0, { SCM_VALIDATE_PROC (1, proc); -#if (SCM_ENABLE_DEPRECATED == 1) - if (scm_is_eq (key, scm_sym_arity)) - scm_c_issue_deprecation_warning - ("Accessing a procedure's arity via `procedure-property' is deprecated.\n" - "Use `procedure-minimum-arity instead."); -#endif - return scm_assq_ref (scm_procedure_properties (proc), key); } #undef FUNC_NAME @@ -179,18 +156,8 @@ SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0, SCM_VALIDATE_PROC (1, proc); -#if (SCM_ENABLE_DEPRECATED == 1) - if (scm_is_eq (key, scm_sym_arity)) - SCM_MISC_ERROR ("arity is a deprecated read-only property", SCM_EOL); -#endif - props = scm_procedure_properties (proc); -#if (SCM_ENABLE_DEPRECATED == 1) - /* cdr past the consed-on arity. */ - props = scm_cdr (props); -#endif - scm_i_pthread_mutex_lock (&overrides_lock); scm_hashq_set_x (overrides, proc, scm_assq_set_x (props, key, val)); scm_i_pthread_mutex_unlock (&overrides_lock); diff --git a/libguile/procprop.h b/libguile/procprop.h index c8c156a25..38d692221 100644 --- a/libguile/procprop.h +++ b/libguile/procprop.h @@ -3,7 +3,7 @@ #ifndef SCM_PROCPROP_H #define SCM_PROCPROP_H -/* Copyright (C) 1995,1996,1998,2000, 2006, 2008, 2009, 2010 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,2000, 2006, 2008, 2009, 2010, 2011 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,9 +28,6 @@ SCM_API SCM scm_sym_name; -#if (SCM_ENABLE_DEPRECATED == 1) -SCM_DEPRECATED SCM scm_sym_arity; -#endif SCM_API SCM scm_sym_system_procedure; diff --git a/libguile/read.c b/libguile/read.c index 676ccf753..3e739586a 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -1385,29 +1385,10 @@ scm_read_sharp (scm_t_wchar chr, SCM port) case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '@': -#if SCM_ENABLE_DEPRECATED - /* See below for 'i' and 'e'. */ - case 'a': - case 'y': - case 'h': - case 'l': -#endif return (scm_i_read_array (port, chr)); case 'i': case 'e': -#if SCM_ENABLE_DEPRECATED - { - /* When next char is '(', it really is an old-style - uniform array. */ - scm_t_wchar next_c = scm_getc (port); - if (next_c != EOF) - scm_ungetc (next_c, port); - if (next_c == '(') - return scm_i_read_array (port, chr); - /* Fall through. */ - } -#endif case 'b': case 'B': case 'o': diff --git a/libguile/socket.c b/libguile/socket.c index 632dd4f40..2e59a15c9 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -39,10 +39,6 @@ #include "libguile/validate.h" #include "libguile/socket.h" -#if SCM_ENABLE_DEPRECATED == 1 -# include "libguile/deprecation.h" -#endif - #ifdef __MINGW32__ #include "win32-socket.h" #include @@ -1414,33 +1410,12 @@ SCM_DEFINE (scm_recv, "recv!", 2, 1, 0, flg = scm_to_int (flags); fd = SCM_FPORT_FDES (sock); -#if SCM_ENABLE_DEPRECATED == 1 - if (SCM_UNLIKELY (scm_is_string (buf))) - { - SCM msg; - char *dest; - size_t len; + SCM_VALIDATE_BYTEVECTOR (1, buf); - scm_c_issue_deprecation_warning - ("Passing a string to `recv!' is deprecated, " - "use a bytevector instead."); - - len = scm_i_string_length (buf); - msg = scm_i_make_string (len, &dest, 0); - SCM_SYSCALL (rv = recv (fd, dest, len, flg)); - scm_string_copy_x (buf, scm_from_int (0), - msg, scm_from_int (0), scm_from_size_t (len)); - } - else -#endif - { - SCM_VALIDATE_BYTEVECTOR (1, buf); - - SCM_SYSCALL (rv = recv (fd, - SCM_BYTEVECTOR_CONTENTS (buf), - SCM_BYTEVECTOR_LENGTH (buf), - flg)); - } + SCM_SYSCALL (rv = recv (fd, + SCM_BYTEVECTOR_CONTENTS (buf), + SCM_BYTEVECTOR_LENGTH (buf), + flg)); if (SCM_UNLIKELY (rv == -1)) SCM_SYSERROR; @@ -1480,35 +1455,12 @@ SCM_DEFINE (scm_send, "send", 2, 1, 0, fd = SCM_FPORT_FDES (sock); -#if SCM_ENABLE_DEPRECATED == 1 - if (SCM_UNLIKELY (scm_is_string (message))) - { - scm_c_issue_deprecation_warning - ("Passing a string to `send' is deprecated, " - "use a bytevector instead."); + SCM_VALIDATE_BYTEVECTOR (1, message); - /* If the string is wide, see if it can be coerced into a narrow - string. */ - if (!scm_i_is_narrow_string (message) - || !scm_i_try_narrow_string (message)) - SCM_MISC_ERROR ("the message string is not 8-bit: ~s", - scm_list_1 (message)); - - SCM_SYSCALL (rv = send (fd, - scm_i_string_chars (message), - scm_i_string_length (message), - flg)); - } - else -#endif - { - SCM_VALIDATE_BYTEVECTOR (1, message); - - SCM_SYSCALL (rv = send (fd, - SCM_BYTEVECTOR_CONTENTS (message), - SCM_BYTEVECTOR_LENGTH (message), - flg)); - } + SCM_SYSCALL (rv = send (fd, + SCM_BYTEVECTOR_CONTENTS (message), + SCM_BYTEVECTOR_LENGTH (message), + flg)); if (rv == -1) SCM_SYSERROR; @@ -1566,52 +1518,28 @@ SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0, ((struct sockaddr *) &addr)->sa_family = AF_UNSPEC; -#if SCM_ENABLE_DEPRECATED == 1 - if (SCM_UNLIKELY (scm_is_string (buf))) - { - char *cbuf; + SCM_VALIDATE_BYTEVECTOR (1, buf); - scm_c_issue_deprecation_warning - ("Passing a string to `recvfrom!' is deprecated, " - "use a bytevector instead."); - - scm_i_get_substring_spec (scm_i_string_length (buf), - start, &offset, end, &cend); - - buf = scm_i_string_start_writing (buf); - cbuf = scm_i_string_writable_chars (buf); - - SCM_SYSCALL (rv = recvfrom (fd, cbuf + offset, - cend - offset, flg, - (struct sockaddr *) &addr, &addr_size)); - scm_i_string_stop_writing (); - } + if (SCM_UNBNDP (start)) + offset = 0; + else + offset = scm_to_size_t (start); + + if (SCM_UNBNDP (end)) + cend = SCM_BYTEVECTOR_LENGTH (buf); else -#endif { - SCM_VALIDATE_BYTEVECTOR (1, buf); - - if (SCM_UNBNDP (start)) - offset = 0; - else - offset = scm_to_size_t (start); - - if (SCM_UNBNDP (end)) - cend = SCM_BYTEVECTOR_LENGTH (buf); - else - { - cend = scm_to_size_t (end); - if (SCM_UNLIKELY (cend >= SCM_BYTEVECTOR_LENGTH (buf) - || cend < offset)) - scm_out_of_range (FUNC_NAME, end); - } - - SCM_SYSCALL (rv = recvfrom (fd, - SCM_BYTEVECTOR_CONTENTS (buf) + offset, - cend - offset, flg, - (struct sockaddr *) &addr, &addr_size)); + cend = scm_to_size_t (end); + if (SCM_UNLIKELY (cend >= SCM_BYTEVECTOR_LENGTH (buf) + || cend < offset)) + scm_out_of_range (FUNC_NAME, end); } + SCM_SYSCALL (rv = recvfrom (fd, + SCM_BYTEVECTOR_CONTENTS (buf) + offset, + cend - offset, flg, + (struct sockaddr *) &addr, &addr_size)); + if (rv == -1) SCM_SYSERROR; @@ -1681,35 +1609,12 @@ SCM_DEFINE (scm_sendto, "sendto", 3, 1, 1, flg = SCM_NUM2ULONG (5, SCM_CAR (args_and_flags)); } -#if SCM_ENABLE_DEPRECATED == 1 - if (SCM_UNLIKELY (scm_is_string (message))) - { - scm_c_issue_deprecation_warning - ("Passing a string to `sendto' is deprecated, " - "use a bytevector instead."); + SCM_VALIDATE_BYTEVECTOR (1, message); - /* If the string is wide, see if it can be coerced into a narrow - string. */ - if (!scm_i_is_narrow_string (message) - || !scm_i_try_narrow_string (message)) - SCM_MISC_ERROR ("the message string is not 8-bit: ~s", - scm_list_1 (message)); - - SCM_SYSCALL (rv = sendto (fd, - scm_i_string_chars (message), - scm_i_string_length (message), - flg, soka, size)); - } - else -#endif - { - SCM_VALIDATE_BYTEVECTOR (1, message); - - SCM_SYSCALL (rv = sendto (fd, - SCM_BYTEVECTOR_CONTENTS (message), - SCM_BYTEVECTOR_LENGTH (message), - flg, soka, size)); - } + SCM_SYSCALL (rv = sendto (fd, + SCM_BYTEVECTOR_CONTENTS (message), + SCM_BYTEVECTOR_LENGTH (message), + flg, soka, size)); if (rv == -1) { diff --git a/libguile/srfi-4.h b/libguile/srfi-4.h index b55fd1d09..0e5afc35a 100644 --- a/libguile/srfi-4.h +++ b/libguile/srfi-4.h @@ -2,7 +2,7 @@ #define SCM_SRFI_4_H /* srfi-4.c --- Homogeneous numeric vector datatypes. * - * Copyright (C) 2001, 2004, 2006, 2008, 2009, 2010 Free Software Foundation, Inc. + * Copyright (C) 2001, 2004, 2006, 2008, 2009, 2010, 2011 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 @@ -279,16 +279,6 @@ SCM_INTERNAL const char *scm_i_uniform_vector_tag (SCM uvec); SCM_INTERNAL scm_i_t_array_ref scm_i_uniform_vector_ref_proc (SCM uvec); SCM_INTERNAL scm_i_t_array_set scm_i_uniform_vector_set_proc (SCM uvec); -#if SCM_ENABLE_DEPRECATED - -/* Deprecated because we want people to use the scm_t_array_handle - interface. -*/ - -SCM_DEPRECATED size_t scm_uniform_element_size (SCM obj); - -#endif - SCM_INTERNAL void scm_init_srfi_4 (void); #endif /* SCM_SRFI_4_H */ diff --git a/libguile/strings.c b/libguile/strings.c index 628dffd01..8e7ad8d82 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -2122,66 +2122,6 @@ scm_i_get_substring_spec (size_t len, *cend = scm_to_unsigned_integer (end, *cstart, len); } -#if SCM_ENABLE_DEPRECATED - -/* When these definitions are removed, it becomes reasonable to use - read-only strings for string literals. For that, change the reader - to create string literals with scm_c_substring_read_only instead of - with scm_c_substring_copy. -*/ - -int -scm_i_deprecated_stringp (SCM str) -{ - scm_c_issue_deprecation_warning - ("SCM_STRINGP is deprecated. Use scm_is_string instead."); - - return scm_is_string (str); -} - -char * -scm_i_deprecated_string_chars (SCM str) -{ - char *chars; - - scm_c_issue_deprecation_warning - ("SCM_STRING_CHARS is deprecated. See the manual for alternatives."); - - /* We don't accept shared substrings here since they are not - null-terminated. - */ - if (IS_SH_STRING (str)) - scm_misc_error (NULL, - "SCM_STRING_CHARS does not work with shared substrings", - SCM_EOL); - - /* We explicitly test for read-only strings to produce a better - error message. - */ - - if (IS_RO_STRING (str)) - scm_misc_error (NULL, - "SCM_STRING_CHARS does not work with read-only strings", - SCM_EOL); - - /* The following is still wrong, of course... - */ - str = scm_i_string_start_writing (str); - chars = scm_i_string_writable_chars (str); - scm_i_string_stop_writing (); - return chars; -} - -size_t -scm_i_deprecated_string_length (SCM str) -{ - scm_c_issue_deprecation_warning - ("SCM_STRING_LENGTH is deprecated. Use scm_c_string_length instead."); - return scm_c_string_length (str); -} - -#endif - static SCM string_handle_ref (scm_t_array_handle *h, size_t index) { diff --git a/libguile/strings.h b/libguile/strings.h index b1fc51a38..0c163db5a 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -235,21 +235,6 @@ SCM_API SCM scm_sys_stringbuf_hist (void); -/* deprecated stuff */ - -#if SCM_ENABLE_DEPRECATED - -SCM_DEPRECATED int scm_i_deprecated_stringp (SCM obj); -SCM_DEPRECATED char *scm_i_deprecated_string_chars (SCM str); -SCM_DEPRECATED size_t scm_i_deprecated_string_length (SCM str); - -#define SCM_STRINGP(x) scm_i_deprecated_stringp(x) -#define SCM_STRING_CHARS(x) scm_i_deprecated_string_chars(x) -#define SCM_STRING_LENGTH(x) scm_i_deprecated_string_length(x) -#define SCM_STRING_UCHARS(str) ((unsigned char *)SCM_STRING_CHARS (str)) - -#endif - SCM_INTERNAL void scm_init_strings (void); #endif /* SCM_STRINGS_H */ diff --git a/libguile/tags.h b/libguile/tags.h index 39d2eaae1..916984262 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -3,7 +3,7 @@ #ifndef SCM_TAGS_H #define SCM_TAGS_H -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010 +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011 * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or @@ -652,13 +652,6 @@ enum scm_tc8_tags -#if (SCM_ENABLE_DEPRECATED == 1) - -#define SCM_CELLP(x) (((sizeof (scm_t_cell) - 1) & SCM_UNPACK (x)) == 0) -#define SCM_NCELLP(x) (!SCM_CELLP (x)) - -#endif - #endif /* SCM_TAGS_H */ /* diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 60d133f20..6dab79eea 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -2065,33 +2065,6 @@ VALUE." (define (module-define-submodule! module name submodule) (hashq-set! (module-submodules module) name submodule)) -;; It used to be, however, that module names were also present in the -;; value namespace. When we enable deprecated code, we preserve this -;; legacy behavior. -;; -;; These shims are defined here instead of in deprecated.scm because we -;; need their definitions before loading other modules. -;; -(begin-deprecated - (define (module-ref-submodule module name) - (or (hashq-ref (module-submodules module) name) - (and (module-submodule-binder module) - ((module-submodule-binder module) module name)) - (let ((var (module-local-variable module name))) - (and var (variable-bound? var) (module? (variable-ref var)) - (begin - (warn "module" module "not in submodules table") - (variable-ref var)))))) - - (define (module-define-submodule! module name submodule) - (let ((var (module-local-variable module name))) - (if (and var - (or (not (variable-bound? var)) - (not (module? (variable-ref var))))) - (warn "defining module" module ": not overriding local definition" var) - (module-define! module name submodule))) - (hashq-set! (module-submodules module) name submodule))) - ;;; {Module-based Loading} @@ -3174,15 +3147,6 @@ module '(ice-9 q) '(make-q q-length))}." (process-use-modules (list quoted-args ...)) *unspecified*)))))) -(define-syntax use-syntax - (syntax-rules () - ((_ spec ...) - (begin - (eval-when (eval load compile expand) - (issue-deprecation-warning - "`use-syntax' is deprecated. Please contact guile-devel for more info.")) - (use-modules spec ...))))) - (include-from-path "ice-9/r6rs-libraries") (define-syntax define-private diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm index f4ae2e365..ca1beec30 100644 --- a/module/ice-9/deprecated.scm +++ b/module/ice-9/deprecated.scm @@ -16,851 +16,5 @@ ;;;; (define-module (ice-9 deprecated) - #:export (substring-move-left! substring-move-right! - dynamic-maybe-call dynamic-maybe-link - try-module-linked try-module-dynamic-link - list* feature? eval-case unmemoize-expr - $asinh - $acosh - $atanh - $sqrt - $abs - $exp - $log - $sin - $cos - $tan - $asin - $acos - $atan - $sinh - $cosh - $tanh - closure? - %nil - @bind - bad-throw - error-catching-loop - error-catching-repl - scm-style-repl - apply-to-args - has-suffix? - scheme-file-suffix - get-option - for-next-option - display-usage-report - transform-usage-lambda - collect - assert-repl-silence - assert-repl-print-unspecified - assert-repl-verbosity - set-repl-prompt! - set-batch-mode?! - repl - pre-unwind-handler-dispatch - default-pre-unwind-handler - handle-system-error - stack-saved? - the-last-stack - save-stack - named-module-use! - top-repl - turn-on-debugging - read-hash-procedures - process-define-module)) + #:export ()) - -;;;; Deprecated definitions. - -(define substring-move-left! - (lambda args - (issue-deprecation-warning - "`substring-move-left!' is deprecated. Use `substring-move!' instead.") - (apply substring-move! args))) -(define substring-move-right! - (lambda args - (issue-deprecation-warning - "`substring-move-right!' is deprecated. Use `substring-move!' instead.") - (apply substring-move! args))) - - - -;; This method of dynamically linking Guile Extensions is deprecated. -;; Use `load-extension' explicitly from Scheme code instead. - -(define (split-c-module-name str) - (let loop ((rev '()) - (start 0) - (pos 0) - (end (string-length str))) - (cond - ((= pos end) - (reverse (cons (string->symbol (substring str start pos)) rev))) - ((eq? (string-ref str pos) #\space) - (loop (cons (string->symbol (substring str start pos)) rev) - (+ pos 1) - (+ pos 1) - end)) - (else - (loop rev start (+ pos 1) end))))) - -(define (convert-c-registered-modules dynobj) - (let ((res (map (lambda (c) - (list (split-c-module-name (car c)) (cdr c) dynobj)) - (c-registered-modules)))) - (c-clear-registered-modules) - res)) - -(define registered-modules '()) - -(define (register-modules dynobj) - (set! registered-modules - (append! (convert-c-registered-modules dynobj) - registered-modules))) - -(define (warn-autoload-deprecation modname) - (issue-deprecation-warning - "Autoloading of compiled code modules is deprecated." - "Write a Scheme file instead that uses `load-extension'.") - (issue-deprecation-warning - (simple-format #f "(You just autoloaded module ~S.)" modname))) - -(define (init-dynamic-module modname) - ;; Register any linked modules which have been registered on the C level - (register-modules #f) - (or-map (lambda (modinfo) - (if (equal? (car modinfo) modname) - (begin - (warn-autoload-deprecation modname) - (set! registered-modules (delq! modinfo registered-modules)) - (let ((mod (resolve-module modname #f))) - (save-module-excursion - (lambda () - (set-current-module mod) - (set-module-public-interface! mod mod) - (dynamic-call (cadr modinfo) (caddr modinfo)) - )) - #t)) - #f)) - registered-modules)) - -(define (dynamic-maybe-call name dynobj) - (issue-deprecation-warning - "`dynamic-maybe-call' is deprecated. " - "Wrap `dynamic-call' in a `false-if-exception' yourself.") - (false-if-exception (dynamic-call name dynobj))) - - -(define (dynamic-maybe-link filename) - (issue-deprecation-warning - "`dynamic-maybe-link' is deprecated. " - "Wrap `dynamic-link' in a `false-if-exception' yourself.") - (false-if-exception (dynamic-link filename))) - -(define (find-and-link-dynamic-module module-name) - (define (make-init-name mod-name) - (string-append "scm_init" - (list->string (map (lambda (c) - (if (or (char-alphabetic? c) - (char-numeric? c)) - c - #\_)) - (string->list mod-name))) - "_module")) - - ;; Put the subdirectory for this module in the car of SUBDIR-AND-LIBNAME, - ;; and the `libname' (the name of the module prepended by `lib') in the cdr - ;; field. For example, if MODULE-NAME is the list (inet tcp-ip udp), then - ;; SUBDIR-AND-LIBNAME will be the pair ("inet/tcp-ip" . "libudp"). - (let ((subdir-and-libname - (let loop ((dirs "") - (syms module-name)) - (if (null? (cdr syms)) - (cons dirs (string-append "lib" (symbol->string (car syms)))) - (loop (string-append dirs (symbol->string (car syms)) "/") - (cdr syms))))) - (init (make-init-name (apply string-append - (map (lambda (s) - (string-append "_" - (symbol->string s))) - module-name))))) - (let ((subdir (car subdir-and-libname)) - (libname (cdr subdir-and-libname))) - - ;; Now look in each dir in %LOAD-PATH for `subdir/libfoo.la'. If that - ;; file exists, fetch the dlname from that file and attempt to link - ;; against it. If `subdir/libfoo.la' does not exist, or does not seem - ;; to name any shared library, look for `subdir/libfoo.so' instead and - ;; link against that. - (let check-dirs ((dir-list %load-path)) - (if (null? dir-list) - #f - (let* ((dir (in-vicinity (car dir-list) subdir)) - (sharlib-full - (or (try-using-libtool-name dir libname) - (try-using-sharlib-name dir libname)))) - (if (and sharlib-full (file-exists? sharlib-full)) - (link-dynamic-module sharlib-full init) - (check-dirs (cdr dir-list))))))))) - -(define (try-using-libtool-name libdir libname) - (let ((libtool-filename (in-vicinity libdir - (string-append libname ".la")))) - (and (file-exists? libtool-filename) - libtool-filename))) - -(define (try-using-sharlib-name libdir libname) - (in-vicinity libdir (string-append libname ".so"))) - -(define (link-dynamic-module filename initname) - ;; Register any linked modules which have been registered on the C level - (register-modules #f) - (let ((dynobj (dynamic-link filename))) - (dynamic-call initname dynobj) - (register-modules dynobj))) - -(define (try-module-linked module-name) - (issue-deprecation-warning - "`try-module-linked' is deprecated." - "See the manual for how more on C extensions.") - (init-dynamic-module module-name)) - -(define (try-module-dynamic-link module-name) - (issue-deprecation-warning - "`try-module-dynamic-link' is deprecated." - "See the manual for how more on C extensions.") - (and (find-and-link-dynamic-module module-name) - (init-dynamic-module module-name))) - - -(define (list* . args) - (issue-deprecation-warning "'list*' is deprecated. Use 'cons*' instead.") - (apply cons* args)) - -(define (feature? sym) - (issue-deprecation-warning - "`feature?' is deprecated. Use `provided?' instead.") - (provided? sym)) - -(define-macro (eval-case . clauses) - (issue-deprecation-warning - "`eval-case' is deprecated. Use `eval-when' instead.") - ;; Practically speaking, eval-case only had load-toplevel and else as - ;; conditions. - (cond - ((assoc-ref clauses '(load-toplevel)) - => (lambda (exps) - ;; the *unspecified so that non-toplevel definitions will be - ;; caught - `(begin *unspecified* . ,exps))) - ((assoc-ref clauses 'else) - => (lambda (exps) - `(begin *unspecified* . ,exps))) - (else - `(begin)))) - -;; The strange prototype system for uniform arrays has been -;; deprecated. -(read-hash-extend - #\y - (lambda (c port) - (issue-deprecation-warning - "The `#y' bytevector syntax is deprecated. Use `#s8' instead.") - (let ((x (read port))) - (cond - ((list? x) (list->s8vector x)) - (else (error "#y needs to be followed by a list" x)))))) - -(define (unmemoize-expr . args) - (issue-deprecation-warning - "`unmemoize-expr' is deprecated. Use `unmemoize-expression' instead.") - (apply unmemoize-expression args)) - -(define ($asinh z) - (issue-deprecation-warning - "`$asinh' is deprecated. Use `asinh' instead.") - (asinh z)) -(define ($acosh z) - (issue-deprecation-warning - "`$acosh' is deprecated. Use `acosh' instead.") - (acosh z)) -(define ($atanh z) - (issue-deprecation-warning - "`$atanh' is deprecated. Use `atanh' instead.") - (atanh z)) -(define ($sqrt z) - (issue-deprecation-warning - "`$sqrt' is deprecated. Use `sqrt' instead.") - (sqrt z)) -(define ($abs z) - (issue-deprecation-warning - "`$abs' is deprecated. Use `abs' instead.") - (abs z)) -(define ($exp z) - (issue-deprecation-warning - "`$exp' is deprecated. Use `exp' instead.") - (exp z)) -(define ($log z) - (issue-deprecation-warning - "`$log' is deprecated. Use `log' instead.") - (log z)) -(define ($sin z) - (issue-deprecation-warning - "`$sin' is deprecated. Use `sin' instead.") - (sin z)) -(define ($cos z) - (issue-deprecation-warning - "`$cos' is deprecated. Use `cos' instead.") - (cos z)) -(define ($tan z) - (issue-deprecation-warning - "`$tan' is deprecated. Use `tan' instead.") - (tan z)) -(define ($asin z) - (issue-deprecation-warning - "`$asin' is deprecated. Use `asin' instead.") - (asin z)) -(define ($acos z) - (issue-deprecation-warning - "`$acos' is deprecated. Use `acos' instead.") - (acos z)) -(define ($atan z) - (issue-deprecation-warning - "`$atan' is deprecated. Use `atan' instead.") - (atan z)) -(define ($sinh z) - (issue-deprecation-warning - "`$sinh' is deprecated. Use `sinh' instead.") - (sinh z)) -(define ($cosh z) - (issue-deprecation-warning - "`$cosh' is deprecated. Use `cosh' instead.") - (cosh z)) -(define ($tanh z) - (issue-deprecation-warning - "`$tanh' is deprecated. Use `tanh' instead.") - (tanh z)) - -(define (closure? x) - (issue-deprecation-warning - "`closure?' is deprecated. Use `procedure?' instead.") - (procedure? x)) - -(define %nil #nil) - -;;; @bind is used by the old elisp code as a dynamic scoping mechanism. -;;; Please let the Guile developers know if you are using this macro. -;;; -(define-syntax @bind - (lambda (x) - (define (bound-member id ids) - (cond ((null? ids) #f) - ((bound-identifier=? id (car ids)) #t) - ((bound-member (car ids) (cdr ids))))) - - (issue-deprecation-warning - "`@bind' is deprecated. Use `with-fluids' instead.") - - (syntax-case x () - ((_ () b0 b1 ...) - #'(let () b0 b1 ...)) - ((_ ((id val) ...) b0 b1 ...) - (and-map identifier? #'(id ...)) - (if (let lp ((ids #'(id ...))) - (cond ((null? ids) #f) - ((bound-member (car ids) (cdr ids)) #t) - (else (lp (cdr ids))))) - (syntax-violation '@bind "duplicate bound identifier" x) - (with-syntax (((old-v ...) (generate-temporaries #'(id ...))) - ((v ...) (generate-temporaries #'(id ...)))) - #'(let ((old-v id) ... - (v val) ...) - (dynamic-wind - (lambda () - (set! id v) ...) - (lambda () b0 b1 ...) - (lambda () - (set! id old-v) ...))))))))) - -;; There are deprecated definitions for module-ref-submodule and -;; module-define-submodule! in boot-9.scm. - -;; Define (%app) and (%app modules), and have (app) alias (%app). This -;; side-effects the-root-module, both to the submodules table and (through -;; module-define-submodule! above) the obarray. -;; -(let ((%app (make-module 31))) - (set-module-name! %app '(%app)) - (module-define-submodule! the-root-module '%app %app) - (module-define-submodule! the-root-module 'app %app) - (module-define-submodule! %app 'modules (resolve-module '() #f))) - -;; Allow code that poked %module-public-interface to keep on working. -;; -(set! module-public-interface - (let ((getter module-public-interface)) - (lambda (mod) - (or (getter mod) - (cond - ((and=> (module-local-variable mod '%module-public-interface) - variable-ref) - => (lambda (iface) - (issue-deprecation-warning -"Setting a module's public interface via munging %module-public-interface is -deprecated. Use set-module-public-interface! instead.") - (set-module-public-interface! mod iface) - iface)) - (else #f)))))) - -(set! set-module-public-interface! - (let ((setter set-module-public-interface!)) - (lambda (mod iface) - (setter mod iface) - (module-define! mod '%module-public-interface iface)))) - -(define (bad-throw key . args) - (issue-deprecation-warning - "`bad-throw' in the default environment is deprecated. -Find it in the `(ice-9 scm-style-repl)' module instead.") - (apply (@ (ice-9 scm-style-repl) bad-throw) key args)) - -(define (error-catching-loop thunk) - (issue-deprecation-warning - "`error-catching-loop' in the default environment is deprecated. -Find it in the `(ice-9 scm-style-repl)' module instead.") - ((@ (ice-9 scm-style-repl) error-catching-loop) thunk)) - -(define (error-catching-repl r e p) - (issue-deprecation-warning - "`error-catching-repl' in the default environment is deprecated. -Find it in the `(ice-9 scm-style-repl)' module instead.") - ((@ (ice-9 scm-style-repl) error-catching-repl) r e p)) - -(define (scm-style-repl) - (issue-deprecation-warning - "`scm-style-repl' in the default environment is deprecated. -Find it in the `(ice-9 scm-style-repl)' module instead, or -better yet, use the repl from `(system repl repl)'.") - ((@ (ice-9 scm-style-repl) scm-style-repl))) - - -;;; Apply-to-args had the following comment attached to it in boot-9, but it's -;;; wrong-headed: in the mentioned case, a point should either be a record or -;;; multiple values. -;;; -;;; apply-to-args is functionally redundant with apply and, worse, -;;; is less general than apply since it only takes two arguments. -;;; -;;; On the other hand, apply-to-args is a syntacticly convenient way to -;;; perform binding in many circumstances when the "let" family of -;;; of forms don't cut it. E.g.: -;;; -;;; (apply-to-args (return-3d-mouse-coords) -;;; (lambda (x y z) -;;; ...)) -;;; - -(define (apply-to-args args fn) - (issue-deprecation-warning - "`apply-to-args' is deprecated. Include a local copy in your program.") - (apply fn args)) - -(define (has-suffix? str suffix) - (issue-deprecation-warning - "`has-suffix?' is deprecated. Use `string-suffix?' instead (args reversed).") - (string-suffix? suffix str)) - -(define scheme-file-suffix - (lambda () - (issue-deprecation-warning - "`scheme-file-suffix' is deprecated. Use `%load-extensions' instead.") - ".scm")) - - - -;;; {Command Line Options} -;;; - -(define (get-option argv kw-opts kw-args return) - (issue-deprecation-warning - "`get-option' is deprecated. Use `(ice-9 getopt-long)' instead.") - (cond - ((null? argv) - (return #f #f argv)) - - ((or (not (eq? #\- (string-ref (car argv) 0))) - (eq? (string-length (car argv)) 1)) - (return 'normal-arg (car argv) (cdr argv))) - - ((eq? #\- (string-ref (car argv) 1)) - (let* ((kw-arg-pos (or (string-index (car argv) #\=) - (string-length (car argv)))) - (kw (symbol->keyword (substring (car argv) 2 kw-arg-pos))) - (kw-opt? (member kw kw-opts)) - (kw-arg? (member kw kw-args)) - (arg (or (and (not (eq? kw-arg-pos (string-length (car argv)))) - (substring (car argv) - (+ kw-arg-pos 1) - (string-length (car argv)))) - (and kw-arg? - (begin (set! argv (cdr argv)) (car argv)))))) - (if (or kw-opt? kw-arg?) - (return kw arg (cdr argv)) - (return 'usage-error kw (cdr argv))))) - - (else - (let* ((char (substring (car argv) 1 2)) - (kw (symbol->keyword char))) - (cond - - ((member kw kw-opts) - (let* ((rest-car (substring (car argv) 2 (string-length (car argv)))) - (new-argv (if (= 0 (string-length rest-car)) - (cdr argv) - (cons (string-append "-" rest-car) (cdr argv))))) - (return kw #f new-argv))) - - ((member kw kw-args) - (let* ((rest-car (substring (car argv) 2 (string-length (car argv)))) - (arg (if (= 0 (string-length rest-car)) - (cadr argv) - rest-car)) - (new-argv (if (= 0 (string-length rest-car)) - (cddr argv) - (cdr argv)))) - (return kw arg new-argv))) - - (else (return 'usage-error kw argv))))))) - -(define (for-next-option proc argv kw-opts kw-args) - (issue-deprecation-warning - "`for-next-option' is deprecated. Use `(ice-9 getopt-long)' instead.") - (let loop ((argv argv)) - (get-option argv kw-opts kw-args - (lambda (opt opt-arg argv) - (and opt (proc opt opt-arg argv loop)))))) - -(define (display-usage-report kw-desc) - (issue-deprecation-warning - "`display-usage-report' is deprecated. Use `(ice-9 getopt-long)' instead.") - (for-each - (lambda (kw) - (or (eq? (car kw) #t) - (eq? (car kw) 'else) - (let* ((opt-desc kw) - (help (cadr opt-desc)) - (opts (car opt-desc)) - (opts-proper (if (string? (car opts)) (cdr opts) opts)) - (arg-name (if (string? (car opts)) - (string-append "<" (car opts) ">") - "")) - (left-part (string-append - (with-output-to-string - (lambda () - (map (lambda (x) (display (keyword->symbol x)) (display " ")) - opts-proper))) - arg-name)) - (middle-part (if (and (< (string-length left-part) 30) - (< (string-length help) 40)) - (make-string (- 30 (string-length left-part)) #\ ) - "\n\t"))) - (display left-part) - (display middle-part) - (display help) - (newline)))) - kw-desc)) - -(define (transform-usage-lambda cases) - (issue-deprecation-warning - "`display-usage-report' is deprecated. Use `(ice-9 getopt-long)' instead.") - (let* ((raw-usage (delq! 'else (map car cases))) - (usage-sans-specials (map (lambda (x) - (or (and (not (list? x)) x) - (and (symbol? (car x)) #t) - (and (boolean? (car x)) #t) - x)) - raw-usage)) - (usage-desc (delq! #t usage-sans-specials)) - (kw-desc (map car usage-desc)) - (kw-opts (apply append (map (lambda (x) (and (not (string? (car x))) x)) kw-desc))) - (kw-args (apply append (map (lambda (x) (and (string? (car x)) (cdr x))) kw-desc))) - (transmogrified-cases (map (lambda (case) - (cons (let ((opts (car case))) - (if (or (boolean? opts) (eq? 'else opts)) - opts - (cond - ((symbol? (car opts)) opts) - ((boolean? (car opts)) opts) - ((string? (caar opts)) (cdar opts)) - (else (car opts))))) - (cdr case))) - cases))) - `(let ((%display-usage (lambda () (display-usage-report ',usage-desc)))) - (lambda (%argv) - (let %next-arg ((%argv %argv)) - (get-option %argv - ',kw-opts - ',kw-args - (lambda (%opt %arg %new-argv) - (case %opt - ,@ transmogrified-cases)))))))) - - - -;;; {collect} -;;; -;;; Similar to `begin' but returns a list of the results of all constituent -;;; forms instead of the result of the last form. -;;; - -(define-syntax collect - (lambda (x) - (issue-deprecation-warning - "`collect' is deprecated. Define it yourself.") - (syntax-case x () - ((_) #''()) - ((_ x x* ...) - #'(let ((val x)) - (cons val (collect x* ...))))))) - - - - -(define (assert-repl-silence v) - (issue-deprecation-warning - "`assert-repl-silence' has moved to `(ice-9 scm-style-repl)'.") - ((@ (ice-9 scm-style-repl) assert-repl-silence) v)) - -(define (assert-repl-print-unspecified v) - (issue-deprecation-warning - "`assert-repl-print-unspecified' has moved to `(ice-9 scm-style-repl)'.") - ((@ (ice-9 scm-style-repl) assert-repl-print-unspecified) v)) - -(define (assert-repl-verbosity v) - (issue-deprecation-warning - "`assert-repl-verbosity' has moved to `(ice-9 scm-style-repl)'.") - ((@ (ice-9 scm-style-repl) assert-repl-verbosity) v)) - -(define (set-repl-prompt! v) - (issue-deprecation-warning - "`set-repl-prompt!' is deprecated. Use `repl-default-prompt-set!' from -the `(system repl common)' module.") - ;; Avoid @, as when bootstrapping it will cause the (system repl common) - ;; module to be loaded at expansion time, which eventually loads srfi-1, but - ;; that fails due to an unbuilt supporting lib... grrrrrrrrr. - ((module-ref (resolve-interface '(system repl common)) - 'repl-default-prompt-set!) - v)) - -(define (set-batch-mode?! arg) - (cond - (arg - (issue-deprecation-warning - "`set-batch-mode?!' is deprecated. Use `ensure-batch-mode!' instead.") - (ensure-batch-mode!)) - (else - (issue-deprecation-warning - "`set-batch-mode?!' with an argument of `#f' is deprecated. Use the -`*repl-stack*' fluid instead.") - #t))) - -(define (repl read evaler print) - (issue-deprecation-warning - "`repl' is deprecated. Define it yourself.") - (let loop ((source (read (current-input-port)))) - (print (evaler source)) - (loop (read (current-input-port))))) - -(define (pre-unwind-handler-dispatch key . args) - (issue-deprecation-warning - "`pre-unwind-handler-dispatch' is deprecated. Use -`default-pre-unwind-handler' from `(ice-9 scm-style-repl)' directly.") - (apply (@ (ice-9 scm-style-repl) default-pre-unwind-handler) key args)) - -(define (default-pre-unwind-handler key . args) - (issue-deprecation-warning - "`default-pre-unwind-handler' is deprecated. Use it from -`(ice-9 scm-style-repl)' if you need it.") - (apply (@ (ice-9 scm-style-repl) default-pre-unwind-handler) key args)) - -(define (handle-system-error key . args) - (issue-deprecation-warning - "`handle-system-error' is deprecated. Use it from -`(ice-9 scm-style-repl)' if you need it.") - (apply (@ (ice-9 scm-style-repl) handle-system-error) key args)) - -(define-syntax stack-saved? - (make-variable-transformer - (lambda (x) - (issue-deprecation-warning - "`stack-saved?' is deprecated. Use it from -`(ice-9 save-stack)' if you need it.") - (syntax-case x (set!) - ((set! id val) - (identifier? #'id) - #'(set! (@ (ice-9 save-stack) stack-saved?) val)) - (id - (identifier? #'id) - #'(@ (ice-9 save-stack) stack-saved?)))))) - -(define-syntax the-last-stack - (lambda (x) - (issue-deprecation-warning - "`the-last-stack' is deprecated. Use it from `(ice-9 save-stack)' -if you need it.") - (syntax-case x () - (id - (identifier? #'id) - #'(@ (ice-9 save-stack) the-last-stack))))) - -(define (save-stack . args) - (issue-deprecation-warning - "`save-stack' is deprecated. Use it from `(ice-9 save-stack)' if you need -it.") - (apply (@ (ice-9 save-stack) save-stack) args)) - -(define (named-module-use! user usee) - (issue-deprecation-warning - "`named-module-use!' is deprecated. Define it yourself if you need it.") - (module-use! (resolve-module user) (resolve-interface usee))) - -(define (top-repl) - (issue-deprecation-warning - "`top-repl' has moved to the `(ice-9 top-repl)' module.") - ((module-ref (resolve-module '(ice-9 top-repl)) 'top-repl))) - -(set! debug-enable - (let ((debug-enable debug-enable)) - (lambda opts - (if (memq 'debug opts) - (begin - (issue-deprecation-warning - "`(debug-enable 'debug)' is obsolete and has no effect." - "Remove it from your code.") - (apply debug-enable (delq 'debug opts))) - (apply debug-enable opts))))) - -(define (turn-on-debugging) - (issue-deprecation-warning - "`(turn-on-debugging)' is obsolete and usually has no effect." - "Debugging capabilities are present by default.") - (debug-enable 'backtrace) - (read-enable 'positions)) - -(define (read-hash-procedures-warning) - (issue-deprecation-warning - "`read-hash-procedures' is deprecated." - "Use the fluid `%read-hash-procedures' instead.")) - -(define-syntax read-hash-procedures - (identifier-syntax - (_ - (begin (read-hash-procedures-warning) - (fluid-ref %read-hash-procedures))) - ((set! _ expr) - (begin (read-hash-procedures-warning) - (fluid-set! %read-hash-procedures expr))))) - -(define (process-define-module args) - (define (missing kw) - (error "missing argument to define-module keyword" kw)) - (define (unrecognized arg) - (error "unrecognized define-module argument" arg)) - - (issue-deprecation-warning - "`process-define-module' is deprecated. Use `define-module*' instead.") - - (let ((name (car args)) - (filename #f) - (pure? #f) - (version #f) - (system? #f) - (duplicates '()) - (transformer #f)) - (let loop ((kws (cdr args)) - (imports '()) - (exports '()) - (re-exports '()) - (replacements '()) - (autoloads '())) - (if (null? kws) - (define-module* name - #:filename filename #:pure pure? #:version version - #:duplicates duplicates #:transformer transformer - #:imports (reverse! imports) - #:exports exports - #:re-exports re-exports - #:replacements replacements - #:autoloads autoloads) - (case (car kws) - ((#:use-module #:use-syntax) - (or (pair? (cdr kws)) - (missing (car kws))) - (cond - ((equal? (cadr kws) '(ice-9 syncase)) - (issue-deprecation-warning - "(ice-9 syncase) is deprecated. Support for syntax-case is now in Guile core.") - (loop (cddr kws) - imports exports re-exports replacements autoloads)) - (else - (let ((iface-spec (cadr kws))) - (if (eq? (car kws) #:use-syntax) - (set! transformer iface-spec)) - (loop (cddr kws) - (cons iface-spec imports) exports re-exports - replacements autoloads))))) - ((#:autoload) - (or (and (pair? (cdr kws)) (pair? (cddr kws))) - (missing (car kws))) - (let ((name (cadr kws)) - (bindings (caddr kws))) - (loop (cdddr kws) - imports exports re-exports - replacements (cons* name bindings autoloads)))) - ((#:no-backtrace) - ;; FIXME: deprecate? - (set! system? #t) - (loop (cdr kws) - imports exports re-exports replacements autoloads)) - ((#:pure) - (set! pure? #t) - (loop (cdr kws) - imports exports re-exports replacements autoloads)) - ((#:version) - (or (pair? (cdr kws)) - (missing (car kws))) - (set! version (cadr kws)) - (loop (cddr kws) - imports exports re-exports replacements autoloads)) - ((#:duplicates) - (if (not (pair? (cdr kws))) - (missing (car kws))) - (set! duplicates (cadr kws)) - (loop (cddr kws) - imports exports re-exports replacements autoloads)) - ((#:export #:export-syntax) - (or (pair? (cdr kws)) - (missing (car kws))) - (loop (cddr kws) - imports (append exports (cadr kws)) re-exports - replacements autoloads)) - ((#:re-export #:re-export-syntax) - (or (pair? (cdr kws)) - (missing (car kws))) - (loop (cddr kws) - imports exports (append re-exports (cadr kws)) - replacements autoloads)) - ((#:replace #:replace-syntax) - (or (pair? (cdr kws)) - (missing (car kws))) - (loop (cddr kws) - imports exports re-exports - (append replacements (cadr kws)) autoloads)) - ((#:filename) - (or (pair? (cdr kws)) - (missing (car kws))) - (set! filename (cadr kws)) - (loop (cddr kws) - imports exports re-exports replacements autoloads)) - (else - (unrecognized kws)))))))