/* Copyright 2003-2004,2006,2008-2018,2020,2021,2022,2025 Free Software Foundation, Inc. This file is part of Guile. Guile is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. Guile is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with Guile. If not, see . */ #ifdef HAVE_CONFIG_H # include #endif #include #define SCM_BUILDING_DEPRECATED_CODE #include "deprecation.h" #include "eval.h" #include "gsubr.h" #include "keywords.h" #include "modules.h" #include "numbers.h" #include "ports.h" #include "symbols.h" #include "threads-internal.h" #include "variable.h" #include "vectors.h" #include "deprecated.h" #if (SCM_ENABLE_DEPRECATED == 1) /* Deprecated functions go here. */ static SCM make_guardian_var; static void init_make_guardian_var (void) { make_guardian_var = scm_c_public_lookup ("ice-9 guardians", "make-guardian"); } SCM scm_make_guardian (void) { static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT; scm_i_pthread_once (&once, init_make_guardian_var); scm_c_issue_deprecation_warning ("The scm_make_guardian C interface is deprecated. Invoke the Scheme " "make-guardian procedure from (ice-9 guardians) instead."); return scm_call_0 (scm_variable_ref (make_guardian_var)); } static SCM make_weak_vector_var; static SCM weak_vector_var; static SCM weak_vector_p_var; static SCM weak_vector_length_var; static SCM weak_vector_ref_var; static SCM weak_vector_set_x_var; static void init_weak_vector_vars (void) { make_weak_vector_var = scm_c_public_lookup ("ice-9 weak-vector", "make-weak-vector"); weak_vector_var = scm_c_public_lookup ("ice-9 weak-vector", "weak-vector"); weak_vector_p_var = scm_c_public_lookup ("ice-9 weak-vector", "weak-vector?"); weak_vector_length_var = scm_c_public_lookup ("ice-9 weak-vector", "weak-vector-length"); weak_vector_ref_var = scm_c_public_lookup ("ice-9 weak-vector", "weak-vector-ref"); weak_vector_set_x_var = scm_c_public_lookup ("ice-9 weak-vector", "weak-vector-set!"); } static void init_weak_vectors (void) { static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT; scm_c_issue_deprecation_warning ("The weak vector C interface is deprecated. Invoke the Scheme " "procedures from (ice-9 weak-vector) instead."); scm_i_pthread_once (&once, init_weak_vector_vars); } SCM scm_make_weak_vector (SCM len, SCM fill) { init_weak_vectors (); return scm_call_2 (scm_variable_ref (make_weak_vector_var), len, SCM_UNBNDP (fill) ? SCM_BOOL_F : fill); } SCM scm_weak_vector (SCM l) { init_weak_vectors (); return scm_call_1 (scm_variable_ref (weak_vector_var), l); } SCM scm_weak_vector_p (SCM x) { init_weak_vectors (); return scm_call_1 (scm_variable_ref (weak_vector_p_var), x); } SCM scm_weak_vector_length (SCM v) { init_weak_vectors (); return scm_call_1 (scm_variable_ref (weak_vector_length_var), v); } SCM scm_weak_vector_ref (SCM v, SCM k) { init_weak_vectors (); return scm_call_2 (scm_variable_ref (weak_vector_ref_var), v, k); } SCM scm_weak_vector_set_x (SCM v, SCM k, SCM x) { init_weak_vectors (); scm_call_3 (scm_variable_ref (weak_vector_set_x_var), v, k, x); return SCM_UNSPECIFIED; } SCM scm_c_make_weak_vector (size_t len, SCM fill) { return scm_make_weak_vector (scm_from_size_t (len), fill); } int scm_is_weak_vector (SCM obj) { return scm_is_true (scm_weak_vector_p (obj)); } size_t scm_c_weak_vector_length (SCM vec) { return scm_to_size_t (scm_weak_vector_length (vec)); } SCM scm_c_weak_vector_ref (SCM v, size_t k) { return scm_weak_vector_ref (v, scm_from_size_t (k)); } void scm_c_weak_vector_set_x (SCM v, size_t k, SCM x) { scm_weak_vector_set_x (v, scm_from_size_t (k), x); } static SCM object_properties_var; static SCM set_object_properties_var; static SCM object_property_var; static SCM set_object_property_var; static void init_object_properties_vars (void) { object_properties_var = scm_c_public_lookup ("ice-9 object-properties", "object-properties"); set_object_properties_var = scm_c_public_lookup ("ice-9 object-properties", "set-object-properties!"); object_property_var = scm_c_public_lookup ("ice-9 object-properties", "object-property"); set_object_property_var = scm_c_public_lookup ("ice-9 object-properties", "set-object-property!"); } static void init_object_properties (void) { static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT; scm_c_issue_deprecation_warning ("The object properties C interface is deprecated. Invoke the Scheme " "procedures from (ice-9 object-properties) instead."); scm_i_pthread_once (&once, init_object_properties_vars); } SCM scm_object_properties (SCM obj) { init_object_properties (); return scm_call_1 (scm_variable_ref (object_properties_var), obj); } SCM scm_set_object_properties_x (SCM obj, SCM alist) { init_object_properties (); return scm_call_2 (scm_variable_ref (set_object_properties_var), obj, alist); } SCM scm_object_property (SCM obj, SCM key) { init_object_properties (); return scm_call_2 (scm_variable_ref (object_property_var), obj, key); } SCM scm_set_object_property_x (SCM obj, SCM key, SCM value) { init_object_properties (); return scm_call_3 (scm_variable_ref (set_object_property_var), obj, key, value); } SCM_GLOBAL_SYMBOL (scm_sym_filename, "filename"); SCM_GLOBAL_SYMBOL (scm_sym_line, "line"); SCM_GLOBAL_SYMBOL (scm_sym_column, "column"); static SCM source_properties_var; static SCM set_source_properties_var; static SCM source_property_var; static SCM set_source_property_var; static SCM cons_source_var; static void init_source_properties_vars (void) { source_properties_var = scm_c_public_lookup ("ice-9 source-properties", "source-properties"); set_source_properties_var = scm_c_public_lookup ("ice-9 source-properties", "set-source-properties!"); source_property_var = scm_c_public_lookup ("ice-9 source-properties", "source-property"); set_source_property_var = scm_c_public_lookup ("ice-9 source-properties", "set-source-property!"); cons_source_var = scm_c_public_lookup ("ice-9 source-properties", "cons-source"); } static void init_source_properties (void) { static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT; scm_c_issue_deprecation_warning ("The source properties C interface is deprecated. Invoke the Scheme " "procedures from (ice-9 source-properties) instead."); scm_i_pthread_once (&once, init_source_properties_vars); } SCM scm_source_properties (SCM obj) { init_source_properties (); return scm_call_1 (scm_variable_ref (source_properties_var), obj); } SCM scm_set_source_properties_x (SCM obj, SCM alist) { init_source_properties (); return scm_call_2 (scm_variable_ref (set_source_properties_var), obj, alist); } SCM scm_source_property (SCM obj, SCM key) { init_source_properties (); return scm_call_2 (scm_variable_ref (source_property_var), obj, key); } SCM scm_set_source_property_x (SCM obj, SCM key, SCM value) { init_source_properties (); return scm_call_3 (scm_variable_ref (set_source_property_var), obj, key, value); } SCM scm_cons_source (SCM orig, SCM x, SCM y) { init_source_properties (); return scm_call_3 (scm_variable_ref (cons_source_var), orig, x, y); } /* In versions 3.0 and prior, the hash table interface could also access weak tables. This is now deprecated. */ static SCM array_fill_x_var; static SCM array_copy_x_var; static SCM array_map_x_var; static SCM array_for_each_var; static SCM array_index_map_x_var; static SCM array_equal_p_var; static SCM array_slice_for_each_var; static SCM array_cell_ref_var; static SCM array_cell_set_x_var; static void init_array_map_vars (void) { array_fill_x_var = scm_c_public_lookup ("ice-9 arrays", "array-fill!"); array_copy_x_var = scm_c_public_lookup ("ice-9 arrays", "array-copy!"); array_map_x_var = scm_c_public_lookup ("ice-9 arrays", "array-map!"); array_for_each_var = scm_c_public_lookup ("ice-9 arrays", "array-for-each"); array_index_map_x_var = scm_c_public_lookup ("ice-9 arrays", "array-index-map!"); array_equal_p_var = scm_c_public_lookup ("ice-9 arrays", "array-equal?"); array_fill_x_var = scm_c_public_lookup ("ice-9 arrays", "array-fill!"); array_cell_ref_var = scm_c_public_lookup ("ice-9 arrays", "array-cell-ref"); array_cell_set_x_var = scm_c_public_lookup ("ice-9 arrays", "array-cell-set!"); } static void init_array_map_functions (void) { static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT; scm_c_issue_deprecation_warning ("Using the array map functions from C is deprecated. Invoke " "array-map!, etc. from (ice-9 arrays) instead."); scm_i_pthread_once (&once, init_array_map_vars); } SCM scm_array_fill_x (SCM ra, SCM fill) { init_array_map_functions (); return scm_call_2 (scm_variable_ref (array_fill_x_var), ra, fill); } SCM scm_array_copy_x (SCM src, SCM dst) { init_array_map_functions (); return scm_call_2 (scm_variable_ref (array_copy_x_var), src, dst); } SCM scm_array_map_x (SCM ra0, SCM proc, SCM lra) { init_array_map_functions (); return scm_apply_2 (scm_variable_ref (array_map_x_var), ra0, proc, lra); } SCM scm_array_for_each (SCM proc, SCM ra0, SCM lra) { init_array_map_functions (); return scm_apply_2 (scm_variable_ref (array_for_each_var), proc, ra0, lra); } SCM scm_array_index_map_x (SCM ra, SCM proc) { init_array_map_functions (); return scm_call_2 (scm_variable_ref (array_index_map_x_var), ra, proc); } SCM scm_array_equal_p (SCM ra0, SCM ra1) { init_array_map_functions (); return scm_call_2 (scm_variable_ref (array_equal_p_var), ra0, ra1); } SCM scm_array_slice_for_each (SCM frank, SCM op, SCM args) { init_array_map_functions (); return scm_apply_2 (scm_variable_ref (array_slice_for_each_var), frank, op, args); } SCM scm_array_slice_for_each_in_order (SCM frank, SCM op, SCM args) { return scm_array_slice_for_each (frank, op, args); } SCM scm_array_cell_ref (SCM array, SCM indices) { init_array_map_functions (); return scm_apply_1 (scm_variable_ref (array_cell_ref_var), array, indices); } SCM scm_array_cell_set_x (SCM array, SCM val, SCM indices) { init_array_map_functions (); return scm_apply_2 (scm_variable_ref (array_cell_set_x_var), array, val, indices); } static SCM char_set_cursor_var; static SCM char_set_ref_var; static SCM char_set_cursor_next_var; static SCM end_of_char_set_p_var; static void init_char_set_cursor_vars (void) { char_set_cursor_var = scm_c_public_lookup ("srfi srfi-14", "char-set-cursor"); char_set_ref_var = scm_c_public_lookup ("srfi srfi-14", "char-set-ref"); char_set_cursor_next_var = scm_c_public_lookup ("srfi srfi-14", "char-set-cursor-next"); end_of_char_set_p_var = scm_c_public_lookup ("srfi srfi-14", "end-of-char-set?"); } static void init_char_set_cursor_functions (void) { static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT; scm_c_issue_deprecation_warning ("Using the char set cursor functions from C is deprecated. Invoke" "char-set-cursor, etc. from (srfi srfi-14) instead."); scm_i_pthread_once (&once, init_char_set_cursor_vars); } SCM scm_char_set_cursor (SCM cs) { init_char_set_cursor_functions (); return scm_call_1 (scm_variable_ref (char_set_cursor_var), cs); } SCM scm_char_set_ref (SCM cs, SCM cursor) { init_char_set_cursor_functions (); return scm_call_2 (scm_variable_ref (char_set_ref_var), cs, cursor); } SCM scm_char_set_cursor_next (SCM cs, SCM cursor) { init_char_set_cursor_functions (); return scm_call_2 (scm_variable_ref (char_set_cursor_next_var), cs, cursor); } SCM scm_end_of_char_set_p (SCM cursor) { init_char_set_cursor_functions (); return scm_call_1 (scm_variable_ref (end_of_char_set_p_var), cursor); } static SCM make_hook_var; static SCM hook_p_var; static SCM hook_empty_p_var; static SCM add_hook_x_var; static SCM remove_hook_x_var; static SCM reset_hook_x_var; static SCM run_hook_var; static SCM hook_to_list_var; static void init_hook_vars (void) { make_hook_var = scm_c_public_lookup ("ice-9 hooks", "make-hook"); hook_p_var = scm_c_public_lookup ("ice-9 hooks", "hook?"); hook_empty_p_var = scm_c_public_lookup ("ice-9 hooks", "hook-empty?"); add_hook_x_var = scm_c_public_lookup ("ice-9 hooks", "add-hook!"); remove_hook_x_var = scm_c_public_lookup ("ice-9 hooks", "remove-hook!"); reset_hook_x_var = scm_c_public_lookup ("ice-9 hooks", "reset-hook!"); run_hook_var = scm_c_public_lookup ("ice-9 hooks", "run-hook"); hook_to_list_var = scm_c_public_lookup ("ice-9 hooks", "hook->list"); } static void init_hook_functions (void) { static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT; scm_c_issue_deprecation_warning ("Using the SCM hook functions from C is deprecated. Invoke" "make-hook, etc. from (ice-9 hooks) instead."); scm_i_pthread_once (&once, init_hook_vars); } SCM scm_make_hook (SCM arity) { init_hook_functions (); return scm_call_0 (scm_variable_ref (make_hook_var)); } SCM scm_hook_p (SCM x) { init_hook_functions (); return scm_call_1 (scm_variable_ref (hook_p_var), x); } SCM scm_hook_empty_p (SCM hook) { init_hook_functions (); return scm_call_1 (scm_variable_ref (hook_empty_p_var), hook); } SCM_KEYWORD (kw_append_p, "append?"); SCM scm_add_hook_x (SCM hook, SCM f, SCM append_p) { init_hook_functions (); return scm_call_4 (scm_variable_ref (add_hook_x_var), hook, f, kw_append_p, SCM_UNBNDP (append_p) ? SCM_BOOL_F : append_p); } SCM scm_remove_hook_x (SCM hook, SCM f) { init_hook_functions (); return scm_call_2 (scm_variable_ref (remove_hook_x_var), hook, f); } SCM scm_reset_hook_x (SCM hook) { init_hook_functions (); return scm_call_1 (scm_variable_ref (reset_hook_x_var), hook); } SCM scm_run_hook (SCM hook, SCM args) { init_hook_functions (); return scm_apply_1 (scm_variable_ref (run_hook_var), hook, args); } void scm_c_run_hook (SCM hook, SCM args) { scm_run_hook (hook, args); } void scm_c_run_hookn (SCM hook, SCM *argsv, size_t nargs) { init_hook_functions (); SCM hook_and_argsv[nargs + 1]; hook_and_argsv[0] = hook; memcpy (&hook_and_argsv[1], argsv, nargs * sizeof (SCM)); scm_call_n (scm_variable_ref (run_hook_var), hook_and_argsv, nargs + 1); } SCM scm_hook_to_list (SCM hook) { init_hook_functions (); return scm_call_1 (scm_variable_ref (hook_to_list_var), hook); } void scm_free_print_state (SCM) { scm_c_issue_deprecation_warning ("scm_free_print_state is no longer useful; " "remove calls to it."); } SCM scm_coerce_outport (SCM val) { scm_c_issue_deprecation_warning ("SCM_COERCE_OUTPORT is deprecated; just return the value instead."); return val; } int scm_valid_oport_value_p (SCM val) { scm_c_issue_deprecation_warning ("scm_valid_oport_value_p is deprecated. Use SCM_OPOUTPORTP instead."); return SCM_OPOUTPORTP (val); } SCM scm_make_print_state (void) { scm_c_issue_deprecation_warning ("scm_make_print_state is deprecated. Use a custom writer instead."); return SCM_BOOL_F; } SCM scm_port_with_print_state (SCM port, SCM pstate) { scm_c_issue_deprecation_warning ("scm_port_with_print_state is deprecated. Just use ports."); return port; } SCM scm_printer_apply (SCM proc, SCM exp, SCM port, scm_print_state *) { scm_c_issue_deprecation_warning ("scm_printer_apply is deprecated. Just use scm_call_2."); return scm_call_2 (proc, exp, port); } SCM scm_get_print_state (SCM port) { scm_c_issue_deprecation_warning ("scm_get_print_state is deprecated. Use a custom writer instead."); return SCM_BOOL_F; } static SCM make_promise_var; static SCM force_var; static SCM promise_p_var; static void init_promise_vars (void) { make_promise_var = scm_c_public_lookup ("ice-9 promises", "make-promise"); force_var = scm_c_public_lookup ("ice-9 promises", "force"); promise_p_var = scm_c_public_lookup ("ice-9 promises", "promise?"); } static void init_promise_functions (void) { static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT; scm_c_issue_deprecation_warning ("Using the SCM promise functions from C is deprecated. Invoke" "force, etc. from (ice-9 promises) or (srfi srfi-45) instead."); scm_i_pthread_once (&once, init_promise_vars); } SCM scm_make_promise (SCM thunk) { init_promise_functions (); return scm_call_1 (scm_variable_ref (make_promise_var), thunk); } SCM scm_promise_p (SCM x) { init_promise_functions (); return scm_call_1 (scm_variable_ref (promise_p_var), x); } SCM scm_force (SCM promise) { init_promise_functions (); return scm_call_1 (scm_variable_ref (force_var), promise); } static SCM make_regexp_var; static SCM regexp_p_var; static SCM regexp_exec_var; static void init_regexp_vars (void) { make_regexp_var = scm_c_public_lookup ("ice-9 regex", "make-regexp"); regexp_p_var = scm_c_public_lookup ("ice-9 regex", "regexp?"); regexp_exec_var = scm_c_public_lookup ("ice-9 regex", "regexp-exec"); } static void init_regexp_functions (void) { static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT; scm_c_issue_deprecation_warning ("Using the SCM regexp functions from C is deprecated. Invoke" "make-regexp, etc. from (ice-9 regex) instead."); scm_i_pthread_once (&once, init_regexp_vars); } SCM scm_make_regexp (SCM pat, SCM flags) { init_regexp_functions (); return scm_apply_1 (scm_variable_ref (make_regexp_var), pat, flags); } SCM scm_regexp_p (SCM x) { init_regexp_functions (); return scm_call_1 (scm_variable_ref (regexp_p_var), x); } SCM scm_regexp_exec (SCM rx, SCM str, SCM start, SCM flags) { init_regexp_functions (); if (SCM_UNBNDP (start)) start = SCM_INUM0; if (SCM_UNBNDP (flags)) flags = SCM_INUM0; return scm_call_4 (scm_variable_ref (regexp_exec_var), rx, str, start, flags); } size_t scm_i_simple_vector_length (SCM v) { scm_c_issue_deprecation_warning ("SCM_SIMPLE_VECTOR_LENGTH is deprecated. Use scm_c_vector_length instead."); return scm_c_vector_length (v); } SCM scm_i_simple_vector_ref (SCM v, size_t k) { scm_c_issue_deprecation_warning ("SCM_SIMPLE_VECTOR_REF is deprecated. Use scm_c_vector_ref instead."); return scm_c_vector_ref (v, k); } void scm_i_simple_vector_set_x (SCM v, size_t k, SCM val) { scm_c_issue_deprecation_warning ("SCM_SIMPLE_VECTOR_SET is deprecated. Use scm_c_vector_set_x instead."); scm_c_vector_set_x (v, k, val); } scm_t_c_hook scm_before_gc_c_hook = { 0, SCM_C_HOOK_NORMAL, NULL }; scm_t_c_hook scm_before_mark_c_hook = { 0, SCM_C_HOOK_NORMAL, NULL }; scm_t_c_hook scm_before_sweep_c_hook = { 0, SCM_C_HOOK_NORMAL, NULL }; scm_t_c_hook scm_after_sweep_c_hook = { 0, SCM_C_HOOK_NORMAL, NULL }; scm_t_c_hook scm_after_gc_c_hook = { 0, SCM_C_HOOK_NORMAL, NULL }; void scm_c_hook_init (scm_t_c_hook *hook, void *hook_data, scm_t_c_hook_type type) { scm_c_issue_deprecation_warning ("C hooks (scm_c_hook_ functions) are deprecated. Implement this yourself."); hook->first = 0; hook->type = type; hook->data = hook_data; } void scm_c_hook_add (scm_t_c_hook *hook, scm_t_c_hook_function func, void *fn_data, int appendp) { scm_c_issue_deprecation_warning ("C hooks (scm_c_hook_ functions) are deprecated. Implement this yourself."); scm_t_c_hook_entry *entry; scm_t_c_hook_entry **loc = &hook->first; entry = scm_allocate_sloppy (SCM_I_CURRENT_THREAD, sizeof (scm_t_c_hook_entry)); if (appendp) while (*loc) loc = &(*loc)->next; entry->next = *loc; entry->func = func; entry->data = fn_data; *loc = entry; } void scm_c_hook_remove (scm_t_c_hook *hook, scm_t_c_hook_function func, void *fn_data) { scm_c_issue_deprecation_warning ("C hooks (scm_c_hook_ functions) are deprecated. Implement this yourself."); scm_t_c_hook_entry **loc = &hook->first; while (*loc) { if ((*loc)->func == func && (*loc)->data == fn_data) { *loc = (*loc)->next; return; } loc = &(*loc)->next; } fprintf (stderr, "Attempt to remove non-existent hook function\n"); abort (); } void * scm_c_hook_run (scm_t_c_hook *hook, void *data) { scm_c_issue_deprecation_warning ("C hooks (scm_c_hook_ functions) are deprecated. Implement this yourself."); return scm_i_c_hook_run (hook, data); } void * scm_i_c_hook_run (scm_t_c_hook *hook, void *data) { scm_t_c_hook_entry *entry = hook->first; scm_t_c_hook_type type = hook->type; void *res = 0; while (entry) { res = (entry->func) (hook->data, entry->data, data); if (res) { if (type == SCM_C_HOOK_OR) break; } else { if (type == SCM_C_HOOK_AND) break; } entry = entry->next; } return res; } void scm_i_init_deprecated () { #include "deprecated.x" } #endif /* SCM_ENABLE_DEPRECATED == 1 */