1 /* This file contains definitions for deprecated features. When you
2 deprecate something, move it here when that is feasible.
5 /* Copyright (C) 2003, 2004, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
7 * This library is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU Lesser General Public License
9 * as published by the Free Software Foundation; either version 3 of
10 * the License, or (at your option) any later version.
12 * This library is distributed in the hope that it will be useful, but
13 * WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 * Lesser General Public License for more details.
17 * You should have received a copy of the GNU Lesser General Public
18 * License along with this library; if not, write to the Free Software
19 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
27 #define SCM_BUILDING_DEPRECATED_CODE
29 #include "libguile/_scm.h"
30 #include "libguile/async.h"
31 #include "libguile/arrays.h"
32 #include "libguile/array-map.h"
33 #include "libguile/generalized-arrays.h"
34 #include "libguile/bytevectors.h"
35 #include "libguile/bitvectors.h"
36 #include "libguile/deprecated.h"
37 #include "libguile/deprecation.h"
38 #include "libguile/snarf.h"
39 #include "libguile/validate.h"
40 #include "libguile/strings.h"
41 #include "libguile/srfi-13.h"
42 #include "libguile/modules.h"
43 #include "libguile/eval.h"
44 #include "libguile/smob.h"
45 #include "libguile/procprop.h"
46 #include "libguile/vectors.h"
47 #include "libguile/hashtab.h"
48 #include "libguile/struct.h"
49 #include "libguile/variable.h"
50 #include "libguile/fluids.h"
51 #include "libguile/ports.h"
52 #include "libguile/eq.h"
53 #include "libguile/read.h"
54 #include "libguile/r6rs-ports.h"
55 #include "libguile/strports.h"
56 #include "libguile/smob.h"
57 #include "libguile/alist.h"
58 #include "libguile/keywords.h"
59 #include "libguile/socket.h"
60 #include "libguile/feature.h"
61 #include "libguile/uniform.h"
67 #include <arpa/inet.h>
69 #if (SCM_ENABLE_DEPRECATED == 1)
71 /* From print.c: Internal symbol names of isyms. Deprecated in guile 1.7.0 on
73 char *scm_isymnames
[] =
79 SCM_REGISTER_PROC(s_substring_move_left_x
, "substring-move-left!", 5, 0, 0, scm_substring_move_x
);
81 SCM_REGISTER_PROC(s_substring_move_right_x
, "substring-move-right!", 5, 0, 0, scm_substring_move_x
);
84 scm_wta (SCM arg
, const char *pos
, const char *s_subr
)
86 if (!s_subr
|| !*s_subr
)
88 if ((~0x1fL
) & (long) pos
)
90 /* error string supplied. */
91 scm_misc_error (s_subr
, pos
, scm_list_1 (arg
));
95 /* numerical error code. */
96 scm_t_bits error
= (scm_t_bits
) pos
;
101 scm_wrong_type_arg (s_subr
, 0, arg
);
103 scm_wrong_type_arg (s_subr
, 1, arg
);
105 scm_wrong_type_arg (s_subr
, 2, arg
);
107 scm_wrong_type_arg (s_subr
, 3, arg
);
109 scm_wrong_type_arg (s_subr
, 4, arg
);
111 scm_wrong_type_arg (s_subr
, 5, arg
);
113 scm_wrong_type_arg (s_subr
, 6, arg
);
115 scm_wrong_type_arg (s_subr
, 7, arg
);
117 scm_wrong_num_args (arg
);
119 scm_out_of_range (s_subr
, arg
);
121 scm_memory_error (s_subr
);
123 /* this shouldn't happen. */
124 scm_misc_error (s_subr
, "Unknown error", SCM_EOL
);
127 return SCM_UNSPECIFIED
;
133 /* We can't use SCM objects here. One should be able to call
134 SCM_REGISTER_MODULE from a C++ constructor for a static
135 object. This happens before main and thus before libguile is
139 struct moddata
*link
;
144 static struct moddata
*registered_mods
= NULL
;
147 scm_register_module_xxx (char *module_name
, void *init_func
)
151 scm_c_issue_deprecation_warning
152 ("`scm_register_module_xxx' is deprecated. Use extensions instead.");
154 /* XXX - should we (and can we) DEFER_INTS here? */
156 for (md
= registered_mods
; md
; md
= md
->link
)
157 if (!strcmp (md
->module_name
, module_name
))
159 md
->init_func
= init_func
;
163 md
= (struct moddata
*) malloc (sizeof (struct moddata
));
167 "guile: can't register module (%s): not enough memory",
172 md
->module_name
= module_name
;
173 md
->init_func
= init_func
;
174 md
->link
= registered_mods
;
175 registered_mods
= md
;
178 SCM_DEFINE (scm_registered_modules
, "c-registered-modules", 0, 0, 0,
180 "Return a list of the object code modules that have been imported into\n"
181 "the current Guile process. Each element of the list is a pair whose\n"
182 "car is the name of the module, and whose cdr is the function handle\n"
183 "for that module's initializer function. The name is the string that\n"
184 "has been passed to scm_register_module_xxx.")
185 #define FUNC_NAME s_scm_registered_modules
191 for (md
= registered_mods
; md
; md
= md
->link
)
192 res
= scm_cons (scm_cons (scm_from_locale_string (md
->module_name
),
193 scm_from_ulong ((unsigned long) md
->init_func
)),
199 SCM_DEFINE (scm_clear_registered_modules
, "c-clear-registered-modules", 0, 0, 0,
201 "Destroy the list of modules registered with the current Guile process.\n"
202 "The return value is unspecified. @strong{Warning:} this function does\n"
203 "not actually unlink or deallocate these modules, but only destroys the\n"
204 "records of which modules have been loaded. It should therefore be used\n"
205 "only by module bookkeeping operations.")
206 #define FUNC_NAME s_scm_clear_registered_modules
208 struct moddata
*md1
, *md2
;
210 SCM_CRITICAL_SECTION_START
;
212 for (md1
= registered_mods
; md1
; md1
= md2
)
217 registered_mods
= NULL
;
219 SCM_CRITICAL_SECTION_END
;
220 return SCM_UNSPECIFIED
;
225 scm_remember (SCM
*ptr
)
227 scm_c_issue_deprecation_warning ("`scm_remember' is deprecated. "
228 "Use the `scm_remember_upto_here*' family of functions instead.");
232 scm_protect_object (SCM obj
)
234 scm_c_issue_deprecation_warning ("`scm_protect_object' is deprecated. "
235 "Use `scm_gc_protect_object' instead.");
236 return scm_gc_protect_object (obj
);
240 scm_unprotect_object (SCM obj
)
242 scm_c_issue_deprecation_warning ("`scm_unprotect_object' is deprecated. "
243 "Use `scm_gc_unprotect_object' instead.");
244 return scm_gc_unprotect_object (obj
);
247 SCM_SYMBOL (scm_sym_app
, "app");
248 SCM_SYMBOL (scm_sym_modules
, "modules");
249 static SCM module_prefix
= SCM_BOOL_F
;
250 static SCM make_modules_in_var
;
251 static SCM beautify_user_module_x_var
;
252 static SCM try_module_autoload_var
;
257 if (module_prefix
== SCM_BOOL_F
)
259 module_prefix
= scm_list_2 (scm_sym_app
, scm_sym_modules
);
260 make_modules_in_var
= scm_c_lookup ("make-modules-in");
261 beautify_user_module_x_var
=
262 scm_c_lookup ("beautify-user-module!");
263 try_module_autoload_var
= scm_c_lookup ("try-module-autoload");
268 scm_module_full_name (SCM name
)
270 init_module_stuff ();
271 if (scm_is_eq (SCM_CAR (name
), scm_sym_app
))
274 return scm_append (scm_list_2 (module_prefix
, name
));
278 scm_make_module (SCM name
)
280 init_module_stuff ();
281 scm_c_issue_deprecation_warning ("`scm_make_module' is deprecated. "
282 "Use `scm_c_define_module instead.");
284 return scm_call_2 (SCM_VARIABLE_REF (make_modules_in_var
),
285 scm_the_root_module (),
286 scm_module_full_name (name
));
290 scm_ensure_user_module (SCM module
)
292 init_module_stuff ();
293 scm_c_issue_deprecation_warning ("`scm_ensure_user_module' is deprecated. "
294 "Use `scm_c_define_module instead.");
296 scm_call_1 (SCM_VARIABLE_REF (beautify_user_module_x_var
), module
);
297 return SCM_UNSPECIFIED
;
301 scm_load_scheme_module (SCM name
)
303 init_module_stuff ();
304 scm_c_issue_deprecation_warning ("`scm_load_scheme_module' is deprecated. "
305 "Use `scm_c_resolve_module instead.");
307 return scm_call_1 (SCM_VARIABLE_REF (try_module_autoload_var
), name
);
310 /* This is implemented in C solely for SCM_COERCE_OUTPORT ... */
313 maybe_close_port (void *data
, SCM port
)
315 SCM except_set
= (SCM
) data
;
317 while (!scm_is_null (except_set
))
319 SCM p
= SCM_COERCE_OUTPORT (SCM_CAR (except_set
));
320 if (scm_is_eq (p
, port
))
322 except_set
= SCM_CDR (except_set
);
325 scm_close_port (port
);
328 SCM_DEFINE (scm_close_all_ports_except
, "close-all-ports-except", 0, 0, 1,
330 "[DEPRECATED] Close all open file ports used by the interpreter\n"
331 "except for those supplied as arguments. This procedure\n"
332 "was intended to be used before an exec call to close file descriptors\n"
333 "which are not needed in the new process. However it has the\n"
334 "undesirable side effect of flushing buffers, so it's deprecated.\n"
335 "Use port-for-each instead.")
336 #define FUNC_NAME s_scm_close_all_ports_except
339 SCM_VALIDATE_REST_ARGUMENT (ports
);
341 for (p
= ports
; !scm_is_null (p
); p
= SCM_CDR (p
))
342 SCM_VALIDATE_OPPORT (SCM_ARG1
, SCM_COERCE_OUTPORT (SCM_CAR (p
)));
344 scm_c_port_for_each (maybe_close_port
, ports
);
346 return SCM_UNSPECIFIED
;
350 SCM_DEFINE (scm_variable_set_name_hint
, "variable-set-name-hint!", 2, 0, 0,
352 "Do not use this function.")
353 #define FUNC_NAME s_scm_variable_set_name_hint
355 SCM_VALIDATE_VARIABLE (1, var
);
356 SCM_VALIDATE_SYMBOL (2, hint
);
357 scm_c_issue_deprecation_warning
358 ("'variable-set-name-hint!' is deprecated. Do not use it.");
359 return SCM_UNSPECIFIED
;
363 SCM_DEFINE (scm_builtin_variable
, "builtin-variable", 1, 0, 0,
365 "Do not use this function.")
366 #define FUNC_NAME s_scm_builtin_variable
368 SCM_VALIDATE_SYMBOL (1,name
);
369 scm_c_issue_deprecation_warning ("`builtin-variable' is deprecated. "
370 "Use module system operations instead.");
371 return scm_sym2var (name
, SCM_BOOL_F
, SCM_BOOL_T
);
376 scm_makstr (size_t len
, int dummy
)
378 scm_c_issue_deprecation_warning
379 ("'scm_makstr' is deprecated. Use 'scm_c_make_string' instead.");
380 return scm_c_make_string (len
, SCM_UNDEFINED
);
384 scm_makfromstr (const char *src
, size_t len
, int dummy SCM_UNUSED
)
386 scm_c_issue_deprecation_warning ("`scm_makfromstr' is deprecated. "
387 "Use `scm_from_locale_stringn' instead.");
389 return scm_from_locale_stringn (src
, len
);
393 scm_internal_with_fluids (SCM fluids
, SCM values
, SCM (*cproc
) (), void *cdata
)
395 scm_c_issue_deprecation_warning ("`scm_internal_with_fluids' is deprecated. "
396 "Use `scm_c_with_fluids' instead.");
398 return scm_c_with_fluids (fluids
, values
, cproc
, cdata
);
402 scm_make_gsubr (const char *name
, int req
, int opt
, int rst
, SCM (*fcn
)())
404 scm_c_issue_deprecation_warning
405 ("`scm_make_gsubr' is deprecated. Use `scm_c_define_gsubr' instead.");
407 return scm_c_define_gsubr (name
, req
, opt
, rst
, fcn
);
411 scm_make_gsubr_with_generic (const char *name
,
412 int req
, int opt
, int rst
,
413 SCM (*fcn
)(), SCM
*gf
)
415 scm_c_issue_deprecation_warning
416 ("`scm_make_gsubr_with_generic' is deprecated. "
417 "Use `scm_c_define_gsubr_with_generic' instead.");
419 return scm_c_define_gsubr_with_generic (name
, req
, opt
, rst
, fcn
, gf
);
423 scm_create_hook (const char *name
, int n_args
)
425 scm_c_issue_deprecation_warning
426 ("'scm_create_hook' is deprecated. "
427 "Use 'scm_make_hook' and 'scm_c_define' instead.");
429 SCM hook
= scm_make_hook (scm_from_int (n_args
));
430 scm_c_define (name
, hook
);
435 SCM_DEFINE (scm_sloppy_memq
, "sloppy-memq", 2, 0, 0,
437 "This procedure behaves like @code{memq}, but does no type or error checking.\n"
438 "Its use is recommended only in writing Guile internals,\n"
439 "not for high-level Scheme programs.")
440 #define FUNC_NAME s_scm_sloppy_memq
442 scm_c_issue_deprecation_warning
443 ("'sloppy-memq' is deprecated. Use 'memq' instead.");
445 for(; scm_is_pair (lst
); lst
= SCM_CDR(lst
))
447 if (scm_is_eq (SCM_CAR (lst
), x
))
455 SCM_DEFINE (scm_sloppy_memv
, "sloppy-memv", 2, 0, 0,
457 "This procedure behaves like @code{memv}, but does no type or error checking.\n"
458 "Its use is recommended only in writing Guile internals,\n"
459 "not for high-level Scheme programs.")
460 #define FUNC_NAME s_scm_sloppy_memv
462 scm_c_issue_deprecation_warning
463 ("'sloppy-memv' is deprecated. Use 'memv' instead.");
465 for(; scm_is_pair (lst
); lst
= SCM_CDR(lst
))
467 if (! scm_is_false (scm_eqv_p (SCM_CAR (lst
), x
)))
475 SCM_DEFINE (scm_sloppy_member
, "sloppy-member", 2, 0, 0,
477 "This procedure behaves like @code{member}, but does no type or error checking.\n"
478 "Its use is recommended only in writing Guile internals,\n"
479 "not for high-level Scheme programs.")
480 #define FUNC_NAME s_scm_sloppy_member
482 scm_c_issue_deprecation_warning
483 ("'sloppy-member' is deprecated. Use 'member' instead.");
485 for(; scm_is_pair (lst
); lst
= SCM_CDR(lst
))
487 if (! scm_is_false (scm_equal_p (SCM_CAR (lst
), x
)))
494 SCM_SYMBOL (scm_end_of_file_key
, "end-of-file");
496 SCM_DEFINE (scm_read_and_eval_x
, "read-and-eval!", 0, 1, 0,
498 "Read a form from @var{port} (standard input by default), and evaluate it\n"
499 "(memoizing it in the process) in the top-level environment. If no data\n"
500 "is left to be read from @var{port}, an @code{end-of-file} error is\n"
502 #define FUNC_NAME s_scm_read_and_eval_x
506 scm_c_issue_deprecation_warning
507 ("'read-and-eval!' is deprecated. Use 'read' and 'eval' instead.");
509 form
= scm_read (port
);
510 if (SCM_EOF_OBJECT_P (form
))
511 scm_ithrow (scm_end_of_file_key
, SCM_EOL
, 1);
512 return scm_eval_x (form
, scm_current_module ());
516 /* Call thunk(closure) underneath a top-level error handler.
517 * If an error occurs, pass the exitval through err_filter and return it.
518 * If no error occurs, return the value of thunk.
522 typedef int setjmp_type
;
524 typedef long setjmp_type
;
527 struct cce_handler_data
{
528 SCM (*err_filter
) ();
533 invoke_err_filter (void *d
, SCM tag
, SCM args
)
535 struct cce_handler_data
*data
= (struct cce_handler_data
*)d
;
536 return data
->err_filter (SCM_BOOL_F
, data
->closure
);
540 scm_call_catching_errors (SCM (*thunk
)(), SCM (*err_filter
)(), void *closure
)
542 scm_c_issue_deprecation_warning
543 ("'scm_call_catching_errors' is deprecated. "
544 "Use 'scm_internal_catch' instead.");
547 struct cce_handler_data data
;
548 data
.err_filter
= err_filter
;
549 data
.closure
= closure
;
550 return scm_internal_catch (SCM_BOOL_T
,
551 (scm_t_catch_body
)thunk
, closure
,
552 (scm_t_catch_handler
)invoke_err_filter
, &data
);
557 scm_make_smob_type_mfpe (char *name
, size_t size
,
559 size_t (*free
) (SCM
),
560 int (*print
) (SCM
, SCM
, scm_print_state
*),
561 SCM (*equalp
) (SCM
, SCM
))
563 scm_c_issue_deprecation_warning
564 ("'scm_make_smob_type_mfpe' is deprecated. "
565 "Use 'scm_make_smob_type' plus 'scm_set_smob_*' instead.");
568 long answer
= scm_make_smob_type (name
, size
);
569 scm_set_smob_mfpe (answer
, mark
, free
, print
, equalp
);
575 scm_set_smob_mfpe (long tc
,
577 size_t (*free
) (SCM
),
578 int (*print
) (SCM
, SCM
, scm_print_state
*),
579 SCM (*equalp
) (SCM
, SCM
))
581 scm_c_issue_deprecation_warning
582 ("'scm_set_smob_mfpe' is deprecated. "
583 "Use 'scm_set_smob_mark' instead, for example.");
585 if (mark
) scm_set_smob_mark (tc
, mark
);
586 if (free
) scm_set_smob_free (tc
, free
);
587 if (print
) scm_set_smob_print (tc
, print
);
588 if (equalp
) scm_set_smob_equalp (tc
, equalp
);
592 scm_smob_free (SCM obj
)
594 long n
= SCM_SMOBNUM (obj
);
596 scm_c_issue_deprecation_warning
597 ("`scm_smob_free' is deprecated. "
598 "It is no longer needed.");
600 if (scm_smobs
[n
].size
> 0)
601 scm_gc_free ((void *) SCM_SMOB_DATA_1 (obj
),
602 scm_smobs
[n
].size
, SCM_SMOBNAME (n
));
607 scm_read_0str (char *expr
)
609 scm_c_issue_deprecation_warning
610 ("scm_read_0str is deprecated. Use scm_c_read_string instead.");
612 return scm_c_read_string (expr
);
616 scm_eval_0str (const char *expr
)
618 scm_c_issue_deprecation_warning
619 ("scm_eval_0str is deprecated. Use scm_c_eval_string instead.");
621 return scm_c_eval_string (expr
);
625 scm_strprint_obj (SCM obj
)
627 scm_c_issue_deprecation_warning
628 ("scm_strprint_obj is deprecated. Use scm_object_to_string instead.");
629 return scm_object_to_string (obj
, SCM_UNDEFINED
);
633 scm_i_object_chars (SCM obj
)
635 scm_c_issue_deprecation_warning
636 ("SCM_CHARS is deprecated. See the manual for alternatives.");
637 if (SCM_STRINGP (obj
))
638 return SCM_STRING_CHARS (obj
);
639 if (SCM_SYMBOLP (obj
))
640 return SCM_SYMBOL_CHARS (obj
);
645 scm_i_object_length (SCM obj
)
647 scm_c_issue_deprecation_warning
648 ("SCM_LENGTH is deprecated. "
649 "Use scm_c_string_length instead, for example, or see the manual.");
650 if (SCM_STRINGP (obj
))
651 return SCM_STRING_LENGTH (obj
);
652 if (SCM_SYMBOLP (obj
))
653 return SCM_SYMBOL_LENGTH (obj
);
654 if (SCM_VECTORP (obj
))
655 return SCM_VECTOR_LENGTH (obj
);
660 scm_sym2ovcell_soft (SCM sym
, SCM obarray
)
663 size_t hash
= scm_i_symbol_hash (sym
) % SCM_VECTOR_LENGTH (obarray
);
665 scm_c_issue_deprecation_warning ("`scm_sym2ovcell_soft' is deprecated. "
666 "Use hashtables instead.");
668 SCM_CRITICAL_SECTION_START
;
669 for (lsym
= SCM_VECTOR_REF (obarray
, hash
);
671 lsym
= SCM_CDR (lsym
))
674 if (scm_is_eq (SCM_CAR (z
), sym
))
676 SCM_CRITICAL_SECTION_END
;
680 SCM_CRITICAL_SECTION_END
;
686 scm_sym2ovcell (SCM sym
, SCM obarray
)
687 #define FUNC_NAME "scm_sym2ovcell"
691 scm_c_issue_deprecation_warning ("`scm_sym2ovcell' is deprecated. "
692 "Use hashtables instead.");
694 answer
= scm_sym2ovcell_soft (sym
, obarray
);
695 if (scm_is_true (answer
))
697 SCM_MISC_ERROR ("uninterned symbol: ~S", scm_list_1 (sym
));
698 return SCM_UNSPECIFIED
; /* not reached */
703 /* Intern a symbol whose name is the LEN characters at NAME in OBARRAY.
705 OBARRAY should be a vector of lists, indexed by the name's hash
706 value, modulo OBARRAY's length. Each list has the form
707 ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the
708 value associated with that symbol (in the current module? in the
711 To "intern" a symbol means: if OBARRAY already contains a symbol by
712 that name, return its (SYMBOL . VALUE) pair; otherwise, create a
713 new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the
714 appropriate list of the OBARRAY, and return the pair.
716 If softness is non-zero, don't create a symbol if it isn't already
717 in OBARRAY; instead, just return #f.
719 If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and
720 return (SYMBOL . SCM_UNDEFINED). */
724 intern_obarray_soft (SCM symbol
, SCM obarray
, unsigned int softness
)
726 size_t raw_hash
= scm_i_symbol_hash (symbol
);
730 if (scm_is_false (obarray
))
735 return scm_cons (symbol
, SCM_UNDEFINED
);
738 hash
= raw_hash
% SCM_VECTOR_LENGTH (obarray
);
740 for (lsym
= SCM_VECTOR_REF(obarray
, hash
);
741 SCM_NIMP (lsym
); lsym
= SCM_CDR (lsym
))
743 SCM a
= SCM_CAR (lsym
);
745 if (scm_is_eq (z
, symbol
))
755 SCM cell
= scm_cons (symbol
, SCM_UNDEFINED
);
756 SCM slot
= SCM_VECTOR_REF (obarray
, hash
);
758 SCM_VECTOR_SET (obarray
, hash
, scm_cons (cell
, slot
));
766 scm_intern_obarray_soft (const char *name
, size_t len
, SCM obarray
,
767 unsigned int softness
)
769 SCM symbol
= scm_from_locale_symboln (name
, len
);
771 scm_c_issue_deprecation_warning ("`scm_intern_obarray_soft' is deprecated. "
772 "Use hashtables instead.");
774 return intern_obarray_soft (symbol
, obarray
, softness
);
778 scm_intern_obarray (const char *name
,size_t len
,SCM obarray
)
780 scm_c_issue_deprecation_warning ("`scm_intern_obarray' is deprecated. "
781 "Use hashtables instead.");
783 return scm_intern_obarray_soft (name
, len
, obarray
, 0);
786 /* Lookup the value of the symbol named by the nul-terminated string
787 NAME in the current module. */
789 scm_symbol_value0 (const char *name
)
791 scm_c_issue_deprecation_warning ("`scm_symbol_value0' is deprecated. "
792 "Use `scm_lookup' instead.");
794 return scm_variable_ref (scm_c_lookup (name
));
797 SCM_DEFINE (scm_string_to_obarray_symbol
, "string->obarray-symbol", 2, 1, 0,
798 (SCM o
, SCM s
, SCM softp
),
799 "Intern a new symbol in @var{obarray}, a symbol table, with name\n"
801 "If @var{obarray} is @code{#f}, use the default system symbol table. If\n"
802 "@var{obarray} is @code{#t}, the symbol should not be interned in any\n"
803 "symbol table; merely return the pair (@var{symbol}\n"
804 ". @var{#<undefined>}).\n\n"
805 "The @var{soft?} argument determines whether new symbol table entries\n"
806 "should be created when the specified symbol is not already present in\n"
807 "@var{obarray}. If @var{soft?} is specified and is a true value, then\n"
808 "new entries should not be added for symbols not already present in the\n"
809 "table; instead, simply return @code{#f}.")
810 #define FUNC_NAME s_scm_string_to_obarray_symbol
816 SCM_VALIDATE_STRING (2, s
);
817 SCM_ASSERT (scm_is_bool (o
) || SCM_VECTORP (o
), o
, SCM_ARG1
, FUNC_NAME
);
819 scm_c_issue_deprecation_warning ("`string->obarray-symbol' is deprecated. "
820 "Use hashtables instead.");
822 softness
= (!SCM_UNBNDP (softp
) && scm_is_true(softp
));
823 /* iron out some screwy calling conventions */
824 if (scm_is_false (o
))
826 /* nothing interesting to do here. */
827 return scm_string_to_symbol (s
);
829 else if (scm_is_eq (o
, SCM_BOOL_T
))
832 vcell
= intern_obarray_soft (scm_string_to_symbol (s
), o
, softness
);
833 if (scm_is_false (vcell
))
835 answer
= SCM_CAR (vcell
);
840 SCM_DEFINE (scm_intern_symbol
, "intern-symbol", 2, 0, 0,
842 "Add a new symbol to @var{obarray} with name @var{string}, bound to an\n"
843 "unspecified initial value. The symbol table is not modified if a symbol\n"
844 "with this name is already present.")
845 #define FUNC_NAME s_scm_intern_symbol
848 SCM_VALIDATE_SYMBOL (2,s
);
849 if (scm_is_false (o
))
850 return SCM_UNSPECIFIED
;
852 scm_c_issue_deprecation_warning ("`intern-symbol' is deprecated. "
853 "Use hashtables instead.");
855 SCM_VALIDATE_VECTOR (1,o
);
856 hval
= scm_i_symbol_hash (s
) % SCM_VECTOR_LENGTH (o
);
857 /* If the symbol is already interned, simply return. */
858 SCM_CRITICAL_SECTION_START
;
862 for (lsym
= SCM_VECTOR_REF (o
, hval
);
864 lsym
= SCM_CDR (lsym
))
866 sym
= SCM_CAR (lsym
);
867 if (scm_is_eq (SCM_CAR (sym
), s
))
869 SCM_CRITICAL_SECTION_END
;
870 return SCM_UNSPECIFIED
;
873 SCM_VECTOR_SET (o
, hval
,
874 scm_acons (s
, SCM_UNDEFINED
,
875 SCM_VECTOR_REF (o
, hval
)));
877 SCM_CRITICAL_SECTION_END
;
878 return SCM_UNSPECIFIED
;
882 SCM_DEFINE (scm_unintern_symbol
, "unintern-symbol", 2, 0, 0,
884 "Remove the symbol with name @var{string} from @var{obarray}. This\n"
885 "function returns @code{#t} if the symbol was present and @code{#f}\n"
887 #define FUNC_NAME s_scm_unintern_symbol
891 scm_c_issue_deprecation_warning ("`unintern-symbol' is deprecated. "
892 "Use hashtables instead.");
894 SCM_VALIDATE_SYMBOL (2,s
);
895 if (scm_is_false (o
))
897 SCM_VALIDATE_VECTOR (1,o
);
898 hval
= scm_i_symbol_hash (s
) % SCM_VECTOR_LENGTH (o
);
899 SCM_CRITICAL_SECTION_START
;
904 for (lsym
= SCM_VECTOR_REF (o
, hval
), lsym_follow
= SCM_BOOL_F
;
906 lsym_follow
= lsym
, lsym
= SCM_CDR (lsym
))
908 sym
= SCM_CAR (lsym
);
909 if (scm_is_eq (SCM_CAR (sym
), s
))
911 /* Found the symbol to unintern. */
912 if (scm_is_false (lsym_follow
))
913 SCM_VECTOR_SET (o
, hval
, lsym
);
915 SCM_SETCDR (lsym_follow
, SCM_CDR(lsym
));
916 SCM_CRITICAL_SECTION_END
;
921 SCM_CRITICAL_SECTION_END
;
926 SCM_DEFINE (scm_symbol_binding
, "symbol-binding", 2, 0, 0,
928 "Look up in @var{obarray} the symbol whose name is @var{string}, and\n"
929 "return the value to which it is bound. If @var{obarray} is @code{#f},\n"
930 "use the global symbol table. If @var{string} is not interned in\n"
931 "@var{obarray}, an error is signalled.")
932 #define FUNC_NAME s_scm_symbol_binding
936 scm_c_issue_deprecation_warning ("`symbol-binding' is deprecated. "
937 "Use hashtables instead.");
939 SCM_VALIDATE_SYMBOL (2,s
);
940 if (scm_is_false (o
))
941 return scm_variable_ref (scm_lookup (s
));
942 SCM_VALIDATE_VECTOR (1,o
);
943 vcell
= scm_sym2ovcell (s
, o
);
944 return SCM_CDR(vcell
);
949 SCM_DEFINE (scm_symbol_interned_p
, "symbol-interned?", 2, 0, 0,
951 "Return @code{#t} if @var{obarray} contains a symbol with name\n"
952 "@var{string}, and @code{#f} otherwise.")
953 #define FUNC_NAME s_scm_symbol_interned_p
957 scm_c_issue_deprecation_warning ("`symbol-interned?' is deprecated. "
958 "Use hashtables instead.");
960 SCM_VALIDATE_SYMBOL (2,s
);
961 if (scm_is_false (o
))
963 SCM var
= scm_sym2var (s
, SCM_BOOL_F
, SCM_BOOL_F
);
964 if (var
!= SCM_BOOL_F
)
968 SCM_VALIDATE_VECTOR (1,o
);
969 vcell
= scm_sym2ovcell_soft (s
, o
);
970 return (SCM_NIMP(vcell
)
977 SCM_DEFINE (scm_symbol_bound_p
, "symbol-bound?", 2, 0, 0,
979 "Return @code{#t} if @var{obarray} contains a symbol with name\n"
980 "@var{string} bound to a defined value. This differs from\n"
981 "@var{symbol-interned?} in that the mere mention of a symbol\n"
982 "usually causes it to be interned; @code{symbol-bound?}\n"
983 "determines whether a symbol has been given any meaningful\n"
985 #define FUNC_NAME s_scm_symbol_bound_p
989 scm_c_issue_deprecation_warning ("`symbol-bound?' is deprecated. "
990 "Use hashtables instead.");
992 SCM_VALIDATE_SYMBOL (2,s
);
993 if (scm_is_false (o
))
995 SCM var
= scm_sym2var (s
, SCM_BOOL_F
, SCM_BOOL_F
);
996 if (SCM_VARIABLEP(var
) && !SCM_UNBNDP(SCM_VARIABLE_REF(var
)))
1000 SCM_VALIDATE_VECTOR (1,o
);
1001 vcell
= scm_sym2ovcell_soft (s
, o
);
1002 return scm_from_bool (SCM_NIMP (vcell
) && !SCM_UNBNDP (SCM_CDR (vcell
)));
1007 SCM_DEFINE (scm_symbol_set_x
, "symbol-set!", 3, 0, 0,
1008 (SCM o
, SCM s
, SCM v
),
1009 "Find the symbol in @var{obarray} whose name is @var{string}, and rebind\n"
1010 "it to @var{value}. An error is signalled if @var{string} is not present\n"
1011 "in @var{obarray}.")
1012 #define FUNC_NAME s_scm_symbol_set_x
1016 scm_c_issue_deprecation_warning ("`symbol-set!' is deprecated. "
1017 "Use the module system instead.");
1019 SCM_VALIDATE_SYMBOL (2,s
);
1020 if (scm_is_false (o
))
1023 return SCM_UNSPECIFIED
;
1025 SCM_VALIDATE_VECTOR (1,o
);
1026 vcell
= scm_sym2ovcell (s
, o
);
1027 SCM_SETCDR (vcell
, v
);
1028 return SCM_UNSPECIFIED
;
1032 #define MAX_PREFIX_LENGTH 30
1034 static int gentemp_counter
;
1036 SCM_DEFINE (scm_gentemp
, "gentemp", 0, 2, 0,
1037 (SCM prefix
, SCM obarray
),
1038 "Create a new symbol with a name unique in an obarray.\n"
1039 "The name is constructed from an optional string @var{prefix}\n"
1040 "and a counter value. The default prefix is @code{t}. The\n"
1041 "@var{obarray} is specified as a second optional argument.\n"
1042 "Default is the system obarray where all normal symbols are\n"
1043 "interned. The counter is increased by 1 at each\n"
1044 "call. There is no provision for resetting the counter.")
1045 #define FUNC_NAME s_scm_gentemp
1047 char buf
[MAX_PREFIX_LENGTH
+ SCM_INTBUFLEN
];
1052 scm_c_issue_deprecation_warning ("`gentemp' is deprecated. "
1053 "Use `gensym' instead.");
1055 if (SCM_UNBNDP (prefix
))
1062 SCM_VALIDATE_STRING (1, prefix
);
1063 len
= scm_i_string_length (prefix
);
1064 name
= scm_to_locale_stringn (prefix
, &len
);
1065 name
= scm_realloc (name
, len
+ SCM_INTBUFLEN
);
1068 if (SCM_UNBNDP (obarray
))
1069 return scm_gensym (prefix
);
1071 SCM_ASSERT ((scm_is_vector (obarray
) || SCM_I_WVECTP (obarray
)),
1076 n_digits
= scm_iint2str (gentemp_counter
++, 10, &name
[len
]);
1077 while (scm_is_true (scm_intern_obarray_soft (name
,
1082 SCM vcell
= scm_intern_obarray_soft (name
,
1088 return SCM_CAR (vcell
);
1094 scm_i_makinum (scm_t_signed_bits val
)
1096 scm_c_issue_deprecation_warning
1097 ("SCM_MAKINUM is deprecated. Use scm_from_int or similar instead.");
1098 return SCM_I_MAKINUM (val
);
1102 scm_i_inump (SCM obj
)
1104 scm_c_issue_deprecation_warning
1105 ("SCM_INUMP is deprecated. Use scm_is_integer or similar instead.");
1106 return SCM_I_INUMP (obj
);
1110 scm_i_inum (SCM obj
)
1112 scm_c_issue_deprecation_warning
1113 ("SCM_INUM is deprecated. Use scm_to_int or similar instead.");
1114 return scm_to_intmax (obj
);
1118 scm_c_string2str (SCM obj
, char *str
, size_t *lenp
)
1120 scm_c_issue_deprecation_warning
1121 ("scm_c_string2str is deprecated. Use scm_to_locale_stringbuf or similar instead.");
1125 char *result
= scm_to_locale_string (obj
);
1127 *lenp
= scm_i_string_length (obj
);
1132 /* Pray that STR is large enough.
1134 size_t len
= scm_to_locale_stringbuf (obj
, str
, SCM_I_SIZE_MAX
);
1143 scm_c_substring2str (SCM obj
, char *str
, size_t start
, size_t len
)
1145 scm_c_issue_deprecation_warning
1146 ("scm_c_substring2str is deprecated. Use scm_substring plus scm_to_locale_stringbuf instead.");
1149 obj
= scm_substring (obj
, scm_from_size_t (start
), SCM_UNDEFINED
);
1151 scm_to_locale_stringbuf (obj
, str
, len
);
1155 /* Converts the given Scheme symbol OBJ into a C string, containing a copy
1156 of OBJ's content with a trailing null byte. If LENP is non-NULL, set
1157 *LENP to the string's length.
1159 When STR is non-NULL it receives the copy and is returned by the function,
1160 otherwise new memory is allocated and the caller is responsible for
1161 freeing it via free(). If out of memory, NULL is returned.
1163 Note that Scheme symbols may contain arbitrary data, including null
1164 characters. This means that null termination is not a reliable way to
1165 determine the length of the returned value. However, the function always
1166 copies the complete contents of OBJ, and sets *LENP to the length of the
1167 scheme symbol (if LENP is non-null). */
1169 scm_c_symbol2str (SCM obj
, char *str
, size_t *lenp
)
1171 return scm_c_string2str (scm_symbol_to_string (obj
), str
, lenp
);
1175 scm_truncate (double x
)
1177 scm_c_issue_deprecation_warning
1178 ("scm_truncate is deprecated. Use scm_c_truncate instead.");
1179 return scm_c_truncate (x
);
1183 scm_round (double x
)
1185 scm_c_issue_deprecation_warning
1186 ("scm_round is deprecated. Use scm_c_round instead.");
1187 return scm_c_round (x
);
1191 scm_sys_expt (SCM x
, SCM y
)
1193 scm_c_issue_deprecation_warning
1194 ("scm_sys_expt is deprecated. Use scm_expt instead.");
1195 return scm_expt (x
, y
);
1199 scm_asinh (double x
)
1201 scm_c_issue_deprecation_warning
1202 ("scm_asinh is deprecated. Use asinh instead.");
1206 return log (x
+ sqrt (x
* x
+ 1));
1211 scm_acosh (double x
)
1213 scm_c_issue_deprecation_warning
1214 ("scm_acosh is deprecated. Use acosh instead.");
1218 return log (x
+ sqrt (x
* x
- 1));
1223 scm_atanh (double x
)
1225 scm_c_issue_deprecation_warning
1226 ("scm_atanh is deprecated. Use atanh instead.");
1230 return 0.5 * log ((1 + x
) / (1 - x
));
1235 scm_sys_atan2 (SCM z1
, SCM z2
)
1237 scm_c_issue_deprecation_warning
1238 ("scm_sys_atan2 is deprecated. Use scm_atan instead.");
1239 return scm_atan (z1
, z2
);
1243 scm_i_deprecated_symbol_chars (SCM sym
)
1245 scm_c_issue_deprecation_warning
1246 ("SCM_SYMBOL_CHARS is deprecated. Use scm_symbol_to_string.");
1248 return (char *)scm_i_symbol_chars (sym
);
1252 scm_i_deprecated_symbol_length (SCM sym
)
1254 scm_c_issue_deprecation_warning
1255 ("SCM_SYMBOL_LENGTH is deprecated. Use scm_symbol_to_string.");
1256 return scm_i_symbol_length (sym
);
1260 scm_i_keywordp (SCM obj
)
1262 scm_c_issue_deprecation_warning
1263 ("SCM_KEYWORDP is deprecated. Use scm_is_keyword instead.");
1264 return scm_is_keyword (obj
);
1268 scm_i_keywordsym (SCM keyword
)
1270 scm_c_issue_deprecation_warning
1271 ("SCM_KEYWORDSYM is deprecated. See scm_keyword_to_symbol instead.");
1272 return scm_keyword_dash_symbol (keyword
);
1276 scm_i_vectorp (SCM x
)
1278 scm_c_issue_deprecation_warning
1279 ("SCM_VECTORP is deprecated. Use scm_is_vector instead.");
1280 return SCM_I_IS_VECTOR (x
);
1284 scm_i_vector_length (SCM x
)
1286 scm_c_issue_deprecation_warning
1287 ("SCM_VECTOR_LENGTH is deprecated. Use scm_c_vector_length instead.");
1288 return SCM_I_VECTOR_LENGTH (x
);
1294 scm_c_issue_deprecation_warning
1295 ("SCM_VELTS is deprecated. Use scm_vector_elements instead.");
1296 return SCM_I_VECTOR_ELTS (x
);
1300 scm_i_writable_velts (SCM x
)
1302 scm_c_issue_deprecation_warning
1303 ("SCM_WRITABLE_VELTS is deprecated. "
1304 "Use scm_vector_writable_elements instead.");
1305 return SCM_I_VECTOR_WELTS (x
);
1309 scm_i_vector_ref (SCM x
, size_t idx
)
1311 scm_c_issue_deprecation_warning
1312 ("SCM_VECTOR_REF is deprecated. "
1313 "Use scm_c_vector_ref or scm_vector_elements instead.");
1314 return scm_c_vector_ref (x
, idx
);
1318 scm_i_vector_set (SCM x
, size_t idx
, SCM val
)
1320 scm_c_issue_deprecation_warning
1321 ("SCM_VECTOR_SET is deprecated. "
1322 "Use scm_c_vector_set_x or scm_vector_writable_elements instead.");
1323 scm_c_vector_set_x (x
, idx
, val
);
1327 scm_vector_equal_p (SCM x
, SCM y
)
1329 scm_c_issue_deprecation_warning
1330 ("scm_vector_euqal_p is deprecated. "
1331 "Use scm_equal_p instead.");
1332 return scm_equal_p (x
, y
);
1335 SCM_DEFINE (scm_uniform_vector_read_x
, "uniform-vector-read!", 1, 3, 0,
1336 (SCM uvec
, SCM port_or_fd
, SCM start
, SCM end
),
1337 "Fill the elements of @var{uvec} by reading\n"
1338 "raw bytes from @var{port-or-fdes}, using host byte order.\n\n"
1339 "The optional arguments @var{start} (inclusive) and @var{end}\n"
1340 "(exclusive) allow a specified region to be read,\n"
1341 "leaving the remainder of the vector unchanged.\n\n"
1342 "When @var{port-or-fdes} is a port, all specified elements\n"
1343 "of @var{uvec} are attempted to be read, potentially blocking\n"
1344 "while waiting for more input or end-of-file.\n"
1345 "When @var{port-or-fd} is an integer, a single call to\n"
1346 "read(2) is made.\n\n"
1347 "An error is signalled when the last element has only\n"
1348 "been partially filled before reaching end-of-file or in\n"
1349 "the single call to read(2).\n\n"
1350 "@code{uniform-vector-read!} returns the number of elements\n"
1352 "@var{port-or-fdes} may be omitted, in which case it defaults\n"
1353 "to the value returned by @code{(current-input-port)}.")
1354 #define FUNC_NAME s_scm_uniform_vector_read_x
1357 size_t c_width
, c_start
, c_end
;
1359 SCM_VALIDATE_BYTEVECTOR (SCM_ARG1
, uvec
);
1361 scm_c_issue_deprecation_warning
1362 ("`uniform-vector-read!' is deprecated. Use `get-bytevector-n!' from\n"
1363 "`(rnrs io ports)' instead.");
1365 if (SCM_UNBNDP (port_or_fd
))
1366 port_or_fd
= scm_current_input_port ();
1368 c_width
= scm_to_size_t (scm_uniform_vector_element_size (uvec
));
1370 c_start
= SCM_UNBNDP (start
) ? 0 : scm_to_size_t (start
);
1373 c_end
= SCM_UNBNDP (end
) ? SCM_BYTEVECTOR_LENGTH (uvec
) : scm_to_size_t (end
);
1376 result
= scm_get_bytevector_n_x (port_or_fd
, uvec
,
1377 scm_from_size_t (c_start
),
1378 scm_from_size_t (c_end
- c_start
));
1380 if (SCM_EOF_OBJECT_P (result
))
1387 SCM_DEFINE (scm_uniform_vector_write
, "uniform-vector-write", 1, 3, 0,
1388 (SCM uvec
, SCM port_or_fd
, SCM start
, SCM end
),
1389 "Write the elements of @var{uvec} as raw bytes to\n"
1390 "@var{port-or-fdes}, in the host byte order.\n\n"
1391 "The optional arguments @var{start} (inclusive)\n"
1392 "and @var{end} (exclusive) allow\n"
1393 "a specified region to be written.\n\n"
1394 "When @var{port-or-fdes} is a port, all specified elements\n"
1395 "of @var{uvec} are attempted to be written, potentially blocking\n"
1396 "while waiting for more room.\n"
1397 "When @var{port-or-fd} is an integer, a single call to\n"
1398 "write(2) is made.\n\n"
1399 "An error is signalled when the last element has only\n"
1400 "been partially written in the single call to write(2).\n\n"
1401 "The number of objects actually written is returned.\n"
1402 "@var{port-or-fdes} may be\n"
1403 "omitted, in which case it defaults to the value returned by\n"
1404 "@code{(current-output-port)}.")
1405 #define FUNC_NAME s_scm_uniform_vector_write
1407 size_t c_width
, c_start
, c_end
;
1409 SCM_VALIDATE_BYTEVECTOR (SCM_ARG1
, uvec
);
1411 scm_c_issue_deprecation_warning
1412 ("`uniform-vector-write' is deprecated. Use `put-bytevector' from\n"
1413 "`(rnrs io ports)' instead.");
1415 if (SCM_UNBNDP (port_or_fd
))
1416 port_or_fd
= scm_current_output_port ();
1418 port_or_fd
= SCM_COERCE_OUTPORT (port_or_fd
);
1420 c_width
= scm_to_size_t (scm_uniform_vector_element_size (uvec
));
1422 c_start
= SCM_UNBNDP (start
) ? 0 : scm_to_size_t (start
);
1425 c_end
= SCM_UNBNDP (end
) ? SCM_BYTEVECTOR_LENGTH (uvec
) : scm_to_size_t (end
);
1428 return scm_put_bytevector (port_or_fd
, uvec
,
1429 scm_from_size_t (c_start
),
1430 scm_from_size_t (c_end
- c_start
));
1435 scm_ra2contig (SCM ra
, int copy
)
1440 for (k
= SCM_I_ARRAY_NDIM (ra
); k
--;)
1441 len
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1442 k
= SCM_I_ARRAY_NDIM (ra
);
1443 if (SCM_I_ARRAY_CONTP (ra
) && ((0 == k
) || (1 == SCM_I_ARRAY_DIMS (ra
)[k
- 1].inc
)))
1445 if (!scm_is_bitvector (SCM_I_ARRAY_V (ra
)))
1447 if ((len
== scm_c_bitvector_length (SCM_I_ARRAY_V (ra
)) &&
1448 0 == SCM_I_ARRAY_BASE (ra
) % SCM_LONG_BIT
&&
1449 0 == len
% SCM_LONG_BIT
))
1452 ret
= scm_i_make_array (k
);
1453 SCM_I_ARRAY_BASE (ret
) = 0;
1456 SCM_I_ARRAY_DIMS (ret
)[k
].lbnd
= SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
;
1457 SCM_I_ARRAY_DIMS (ret
)[k
].ubnd
= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
;
1458 SCM_I_ARRAY_DIMS (ret
)[k
].inc
= inc
;
1459 inc
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1461 SCM_I_ARRAY_V (ret
) =
1462 scm_make_generalized_vector (scm_array_type (ra
), scm_from_size_t (inc
),
1465 scm_array_copy_x (ra
, ret
);
1469 SCM_DEFINE (scm_uniform_array_read_x
, "uniform-array-read!", 1, 3, 0,
1470 (SCM ura
, SCM port_or_fd
, SCM start
, SCM end
),
1471 "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
1472 "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
1473 "binary objects from @var{port-or-fdes}.\n"
1474 "If an end of file is encountered,\n"
1475 "the objects up to that point are put into @var{ura}\n"
1476 "(starting at the beginning) and the remainder of the array is\n"
1478 "The optional arguments @var{start} and @var{end} allow\n"
1479 "a specified region of a vector (or linearized array) to be read,\n"
1480 "leaving the remainder of the vector unchanged.\n\n"
1481 "@code{uniform-array-read!} returns the number of objects read.\n"
1482 "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
1483 "returned by @code{(current-input-port)}.")
1484 #define FUNC_NAME s_scm_uniform_array_read_x
1486 if (SCM_UNBNDP (port_or_fd
))
1487 port_or_fd
= scm_current_input_port ();
1489 if (scm_is_uniform_vector (ura
))
1491 return scm_uniform_vector_read_x (ura
, port_or_fd
, start
, end
);
1493 else if (SCM_I_ARRAYP (ura
))
1495 size_t base
, vlen
, cstart
, cend
;
1498 cra
= scm_ra2contig (ura
, 0);
1499 base
= SCM_I_ARRAY_BASE (cra
);
1500 vlen
= SCM_I_ARRAY_DIMS (cra
)->inc
*
1501 (SCM_I_ARRAY_DIMS (cra
)->ubnd
- SCM_I_ARRAY_DIMS (cra
)->lbnd
+ 1);
1505 if (!SCM_UNBNDP (start
))
1507 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
1508 if (!SCM_UNBNDP (end
))
1509 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
1512 ans
= scm_uniform_vector_read_x (SCM_I_ARRAY_V (cra
), port_or_fd
,
1513 scm_from_size_t (base
+ cstart
),
1514 scm_from_size_t (base
+ cend
));
1516 if (!scm_is_eq (cra
, ura
))
1517 scm_array_copy_x (cra
, ura
);
1521 scm_wrong_type_arg_msg (NULL
, 0, ura
, "array");
1525 SCM_DEFINE (scm_uniform_array_write
, "uniform-array-write", 1, 3, 0,
1526 (SCM ura
, SCM port_or_fd
, SCM start
, SCM end
),
1527 "Writes all elements of @var{ura} as binary objects to\n"
1528 "@var{port-or-fdes}.\n\n"
1529 "The optional arguments @var{start}\n"
1530 "and @var{end} allow\n"
1531 "a specified region of a vector (or linearized array) to be written.\n\n"
1532 "The number of objects actually written is returned.\n"
1533 "@var{port-or-fdes} may be\n"
1534 "omitted, in which case it defaults to the value returned by\n"
1535 "@code{(current-output-port)}.")
1536 #define FUNC_NAME s_scm_uniform_array_write
1538 if (SCM_UNBNDP (port_or_fd
))
1539 port_or_fd
= scm_current_output_port ();
1541 if (scm_is_uniform_vector (ura
))
1543 return scm_uniform_vector_write (ura
, port_or_fd
, start
, end
);
1545 else if (SCM_I_ARRAYP (ura
))
1547 size_t base
, vlen
, cstart
, cend
;
1550 cra
= scm_ra2contig (ura
, 1);
1551 base
= SCM_I_ARRAY_BASE (cra
);
1552 vlen
= SCM_I_ARRAY_DIMS (cra
)->inc
*
1553 (SCM_I_ARRAY_DIMS (cra
)->ubnd
- SCM_I_ARRAY_DIMS (cra
)->lbnd
+ 1);
1557 if (!SCM_UNBNDP (start
))
1559 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
1560 if (!SCM_UNBNDP (end
))
1561 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
1564 ans
= scm_uniform_vector_write (SCM_I_ARRAY_V (cra
), port_or_fd
,
1565 scm_from_size_t (base
+ cstart
),
1566 scm_from_size_t (base
+ cend
));
1571 scm_wrong_type_arg_msg (NULL
, 0, ura
, "array");
1576 scm_i_cur_inp (void)
1578 scm_c_issue_deprecation_warning
1579 ("scm_cur_inp is deprecated. Use scm_current_input_port instead.");
1580 return scm_current_input_port ();
1584 scm_i_cur_outp (void)
1586 scm_c_issue_deprecation_warning
1587 ("scm_cur_outp is deprecated. Use scm_current_output_port instead.");
1588 return scm_current_output_port ();
1592 scm_i_cur_errp (void)
1594 scm_c_issue_deprecation_warning
1595 ("scm_cur_errp is deprecated. Use scm_current_error_port instead.");
1596 return scm_current_error_port ();
1600 scm_i_cur_loadp (void)
1602 scm_c_issue_deprecation_warning
1603 ("scm_cur_loadp is deprecated. Use scm_current_load_port instead.");
1604 return scm_current_load_port ();
1608 scm_i_progargs (void)
1610 scm_c_issue_deprecation_warning
1611 ("scm_progargs is deprecated. Use scm_program_arguments instead.");
1612 return scm_program_arguments ();
1616 scm_i_deprecated_dynwinds (void)
1618 scm_c_issue_deprecation_warning
1619 ("scm_dynwinds is deprecated. Do not use it.");
1620 return scm_i_dynwinds ();
1624 scm_i_stack_base (void)
1626 scm_c_issue_deprecation_warning
1627 ("scm_stack_base is deprecated. Do not use it.");
1628 return SCM_I_CURRENT_THREAD
->base
;
1632 scm_i_fluidp (SCM x
)
1634 scm_c_issue_deprecation_warning
1635 ("SCM_FLUIDP is deprecated. Use scm_is_fluid instead.");
1636 return scm_is_fluid (x
);
1642 #ifdef HAVE_NETWORKING
1644 SCM_DEFINE (scm_inet_aton
, "inet-aton", 1, 0, 0,
1646 "Convert an IPv4 Internet address from printable string\n"
1647 "(dotted decimal notation) to an integer. E.g.,\n\n"
1649 "(inet-aton \"127.0.0.1\") @result{} 2130706433\n"
1651 #define FUNC_NAME s_scm_inet_aton
1653 scm_c_issue_deprecation_warning
1654 ("`inet-aton' is deprecated. Use `inet-pton' instead.");
1656 return scm_inet_pton (scm_from_int (AF_INET
), address
);
1661 SCM_DEFINE (scm_inet_ntoa
, "inet-ntoa", 1, 0, 0,
1663 "Convert an IPv4 Internet address to a printable\n"
1664 "(dotted decimal notation) string. E.g.,\n\n"
1666 "(inet-ntoa 2130706433) @result{} \"127.0.0.1\"\n"
1668 #define FUNC_NAME s_scm_inet_ntoa
1670 scm_c_issue_deprecation_warning
1671 ("`inet-ntoa' is deprecated. Use `inet-ntop' instead.");
1673 return scm_inet_ntop (scm_from_int (AF_INET
), inetid
);
1677 #endif /* HAVE_NETWORKING */
1681 scm_i_defer_ints_etc ()
1683 scm_c_issue_deprecation_warning
1684 ("SCM_DEFER_INTS etc are deprecated. "
1685 "Use a mutex instead if appropriate.");
1689 scm_i_mask_ints (void)
1691 scm_c_issue_deprecation_warning ("`scm_mask_ints' is deprecated.");
1692 return (SCM_I_CURRENT_THREAD
->block_asyncs
!= 0);
1697 scm_guard (SCM guardian
, SCM obj
, int throw_p
)
1699 scm_c_issue_deprecation_warning
1700 ("scm_guard is deprecated. Use scm_call_1 instead.");
1702 return scm_call_1 (guardian
, obj
);
1706 scm_get_one_zombie (SCM guardian
)
1708 scm_c_issue_deprecation_warning
1709 ("scm_guard is deprecated. Use scm_call_0 instead.");
1711 return scm_call_0 (guardian
);
1714 SCM_DEFINE (scm_guardian_destroyed_p
, "guardian-destroyed?", 1, 0, 0,
1716 "Return @code{#t} if @var{guardian} has been destroyed, otherwise @code{#f}.")
1717 #define FUNC_NAME s_scm_guardian_destroyed_p
1719 scm_c_issue_deprecation_warning
1720 ("'guardian-destroyed?' is deprecated.");
1725 SCM_DEFINE (scm_guardian_greedy_p
, "guardian-greedy?", 1, 0, 0,
1727 "Return @code{#t} if @var{guardian} is a greedy guardian, otherwise @code{#f}.")
1728 #define FUNC_NAME s_scm_guardian_greedy_p
1730 scm_c_issue_deprecation_warning
1731 ("'guardian-greedy?' is deprecated.");
1736 SCM_DEFINE (scm_destroy_guardian_x
, "destroy-guardian!", 1, 0, 0,
1738 "Destroys @var{guardian}, by making it impossible to put any more\n"
1739 "objects in it or get any objects from it. It also unguards any\n"
1740 "objects guarded by @var{guardian}.")
1741 #define FUNC_NAME s_scm_destroy_guardian_x
1743 scm_c_issue_deprecation_warning
1744 ("'destroy-guardian!' is deprecated and ineffective.");
1745 return SCM_UNSPECIFIED
;
1750 /* GC-related things. */
1752 unsigned long scm_mallocated
, scm_mtrigger
;
1753 size_t scm_max_segment_size
;
1755 #if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST)
1757 scm_map_free_list (void)
1763 #if defined (GUILE_DEBUG_FREELIST)
1765 scm_gc_set_debug_check_freelist_x (SCM flag
)
1767 return SCM_UNSPECIFIED
;
1774 * Trampolines were an intent to speed up calling the same Scheme procedure many
1777 * However, this was the wrong thing to optimize; if you really know what you're
1778 * calling, call its function directly, otherwise you're in Scheme-land, and we
1779 * have many better tricks there (inlining, for example, which can remove the
1780 * need for closures and free variables).
1782 * Also, in the normal debugging case, trampolines were being computed but not
1787 scm_trampoline_0 (SCM proc
)
1789 scm_c_issue_deprecation_warning
1790 ("`scm_trampoline_0' is deprecated. Just use `scm_call_0' instead.");
1795 scm_trampoline_1 (SCM proc
)
1797 scm_c_issue_deprecation_warning
1798 ("`scm_trampoline_1' is deprecated. Just use `scm_call_1' instead.");
1803 scm_trampoline_2 (SCM proc
)
1805 scm_c_issue_deprecation_warning
1806 ("`scm_trampoline_2' is deprecated. Just use `scm_call_2' instead.");
1811 scm_i_subr_p (SCM x
)
1813 scm_c_issue_deprecation_warning ("`scm_subr_p' is deprecated. Use SCM_PRIMITIVE_P instead.");
1814 return SCM_PRIMITIVE_P (x
);
1820 scm_internal_lazy_catch (SCM tag
, scm_t_catch_body body
, void *body_data
, scm_t_catch_handler handler
, void *handler_data
)
1822 scm_c_issue_deprecation_warning
1823 ("`scm_internal_lazy_catch' is no longer supported. Instead this call will\n"
1824 "dispatch to `scm_c_with_throw_handler'. Your handler will be invoked from\n"
1825 "within the dynamic context of the corresponding `throw'.\n"
1826 "\nTHIS COULD CHANGE YOUR PROGRAM'S BEHAVIOR.\n\n"
1827 "Please modify your program to use `scm_c_with_throw_handler' directly,\n"
1828 "and adapt it (if necessary) to expect to be within the dynamic context\n"
1830 return scm_c_with_throw_handler (tag
, body
, body_data
, handler
, handler_data
, 0);
1833 SCM_DEFINE (scm_lazy_catch
, "lazy-catch", 3, 0, 0,
1834 (SCM key
, SCM thunk
, SCM handler
),
1835 "This behaves exactly like @code{catch}, except that it does\n"
1836 "not unwind the stack before invoking @var{handler}.\n"
1837 "If the @var{handler} procedure returns normally, Guile\n"
1838 "rethrows the same exception again to the next innermost catch,\n"
1839 "lazy-catch or throw handler. If the @var{handler} exits\n"
1840 "non-locally, that exit determines the continuation.")
1841 #define FUNC_NAME s_scm_lazy_catch
1843 struct scm_body_thunk_data c
;
1845 SCM_ASSERT (scm_is_symbol (key
) || scm_is_eq (key
, SCM_BOOL_T
),
1846 key
, SCM_ARG1
, FUNC_NAME
);
1849 c
.body_proc
= thunk
;
1851 scm_c_issue_deprecation_warning
1852 ("`lazy-catch' is no longer supported. Instead this call will dispatch\n"
1853 "to `with-throw-handler'. Your handler will be invoked from within the\n"
1854 "dynamic context of the corresponding `throw'.\n"
1855 "\nTHIS COULD CHANGE YOUR PROGRAM'S BEHAVIOR.\n\n"
1856 "Please modify your program to use `with-throw-handler' directly, and\n"
1857 "adapt it (if necessary) to expect to be within the dynamic context of\n"
1860 return scm_c_with_throw_handler (key
,
1862 scm_handle_by_proc
, &handler
, 0);
1871 scm_raequal (SCM ra0
, SCM ra1
)
1873 return scm_array_equal_p (ra0
, ra1
);
1880 SCM_DEFINE (scm_dynamic_args_call
, "dynamic-args-call", 3, 0, 0,
1881 (SCM func
, SCM dobj
, SCM args
),
1882 "Call the C function indicated by @var{func} and @var{dobj},\n"
1883 "just like @code{dynamic-call}, but pass it some arguments and\n"
1884 "return its return value. The C function is expected to take\n"
1885 "two arguments and return an @code{int}, just like @code{main}:\n"
1887 "int c_func (int argc, char **argv);\n"
1888 "@end smallexample\n\n"
1889 "The parameter @var{args} must be a list of strings and is\n"
1890 "converted into an array of @code{char *}. The array is passed\n"
1891 "in @var{argv} and its size in @var{argc}. The return value is\n"
1892 "converted to a Scheme number and returned from the call to\n"
1893 "@code{dynamic-args-call}.")
1894 #define FUNC_NAME s_scm_dynamic_args_call
1896 int (*fptr
) (int argc
, char **argv
);
1900 if (scm_is_string (func
))
1903 func
= scm_dynamic_func (func
, dobj
);
1905 scm_misc_error ("dynamic-args-call",
1906 "dynamic-func not available to resolve ~S",
1910 SCM_VALIDATE_POINTER (SCM_ARG1
, func
);
1912 fptr
= SCM_POINTER_VALUE (func
);
1914 argv
= scm_i_allocate_string_pointers (args
);
1915 for (argc
= 0; argv
[argc
]; argc
++)
1917 result
= (*fptr
) (argc
, argv
);
1919 return scm_from_int (result
);
1928 scm_badargsp (SCM formals
, SCM args
)
1930 scm_c_issue_deprecation_warning
1931 ("`scm_badargsp' is deprecated. Copy it into your project if you need it.");
1933 while (!scm_is_null (formals
))
1935 if (!scm_is_pair (formals
))
1937 if (scm_is_null (args
))
1939 formals
= scm_cdr (formals
);
1940 args
= scm_cdr (args
);
1942 return !scm_is_null (args
) ? 1 : 0;
1947 /* scm_internal_stack_catch
1948 Use this one if you want debugging information to be stored in
1949 the-last-stack on error. */
1952 ss_handler (void *data SCM_UNUSED
, SCM tag
, SCM throw_args
)
1955 scm_fluid_set_x (scm_variable_ref
1956 (scm_c_module_lookup
1957 (scm_c_resolve_module ("ice-9 save-stack"),
1959 scm_make_stack (SCM_BOOL_T
, SCM_EOL
));
1960 /* Throw the error */
1961 return scm_throw (tag
, throw_args
);
1967 scm_t_catch_body body
;
1972 cwss_body (void *data
)
1974 struct cwss_data
*d
= data
;
1975 return scm_c_with_throw_handler (d
->tag
, d
->body
, d
->data
, ss_handler
, NULL
, 0);
1979 scm_internal_stack_catch (SCM tag
,
1980 scm_t_catch_body body
,
1982 scm_t_catch_handler handler
,
1989 scm_c_issue_deprecation_warning
1990 ("`scm_internal_stack_catch' is deprecated. Talk to guile-devel if you see this message.");
1991 return scm_internal_catch (tag
, cwss_body
, &d
, handler
, handler_data
);
1997 scm_short2num (short x
)
1999 scm_c_issue_deprecation_warning
2000 ("`scm_short2num' is deprecated. Use scm_from_short instead.");
2001 return scm_from_short (x
);
2005 scm_ushort2num (unsigned short x
)
2007 scm_c_issue_deprecation_warning
2008 ("`scm_ushort2num' is deprecated. Use scm_from_ushort instead.");
2009 return scm_from_ushort (x
);
2015 scm_c_issue_deprecation_warning
2016 ("`scm_int2num' is deprecated. Use scm_from_int instead.");
2017 return scm_from_int (x
);
2021 scm_uint2num (unsigned int x
)
2023 scm_c_issue_deprecation_warning
2024 ("`scm_uint2num' is deprecated. Use scm_from_uint instead.");
2025 return scm_from_uint (x
);
2029 scm_long2num (long x
)
2031 scm_c_issue_deprecation_warning
2032 ("`scm_long2num' is deprecated. Use scm_from_long instead.");
2033 return scm_from_long (x
);
2037 scm_ulong2num (unsigned long x
)
2039 scm_c_issue_deprecation_warning
2040 ("`scm_ulong2num' is deprecated. Use scm_from_ulong instead.");
2041 return scm_from_ulong (x
);
2045 scm_size2num (size_t x
)
2047 scm_c_issue_deprecation_warning
2048 ("`scm_size2num' is deprecated. Use scm_from_size_t instead.");
2049 return scm_from_size_t (x
);
2053 scm_ptrdiff2num (ptrdiff_t x
)
2055 scm_c_issue_deprecation_warning
2056 ("`scm_ptrdiff2num' is deprecated. Use scm_from_ssize_t instead.");
2057 return scm_from_ssize_t (x
);
2061 scm_num2short (SCM x
, unsigned long pos
, const char *s_caller
)
2063 scm_c_issue_deprecation_warning
2064 ("`scm_num2short' is deprecated. Use scm_to_short instead.");
2065 return scm_to_short (x
);
2069 scm_num2ushort (SCM x
, unsigned long pos
, const char *s_caller
)
2071 scm_c_issue_deprecation_warning
2072 ("`scm_num2ushort' is deprecated. Use scm_to_ushort instead.");
2073 return scm_to_ushort (x
);
2077 scm_num2int (SCM x
, unsigned long pos
, const char *s_caller
)
2079 scm_c_issue_deprecation_warning
2080 ("`scm_num2int' is deprecated. Use scm_to_int instead.");
2081 return scm_to_int (x
);
2085 scm_num2uint (SCM x
, unsigned long pos
, const char *s_caller
)
2087 scm_c_issue_deprecation_warning
2088 ("`scm_num2uint' is deprecated. Use scm_to_uint instead.");
2089 return scm_to_uint (x
);
2093 scm_num2long (SCM x
, unsigned long pos
, const char *s_caller
)
2095 scm_c_issue_deprecation_warning
2096 ("`scm_num2long' is deprecated. Use scm_to_long instead.");
2097 return scm_to_long (x
);
2101 scm_num2ulong (SCM x
, unsigned long pos
, const char *s_caller
)
2103 scm_c_issue_deprecation_warning
2104 ("`scm_num2ulong' is deprecated. Use scm_to_ulong instead.");
2105 return scm_to_ulong (x
);
2109 scm_num2size (SCM x
, unsigned long pos
, const char *s_caller
)
2111 scm_c_issue_deprecation_warning
2112 ("`scm_num2size' is deprecated. Use scm_to_size_t instead.");
2113 return scm_to_size_t (x
);
2117 scm_num2ptrdiff (SCM x
, unsigned long pos
, const char *s_caller
)
2119 scm_c_issue_deprecation_warning
2120 ("`scm_num2ptrdiff' is deprecated. Use scm_to_ssize_t instead.");
2121 return scm_to_ssize_t (x
);
2124 #if SCM_SIZEOF_LONG_LONG != 0
2127 scm_long_long2num (long long x
)
2129 scm_c_issue_deprecation_warning
2130 ("`scm_long_long2num' is deprecated. Use scm_from_long_long instead.");
2131 return scm_from_long_long (x
);
2135 scm_ulong_long2num (unsigned long long x
)
2137 scm_c_issue_deprecation_warning
2138 ("`scm_ulong_long2num' is deprecated. Use scm_from_ulong_long instead.");
2139 return scm_from_ulong_long (x
);
2143 scm_num2long_long (SCM x
, unsigned long pos
, const char *s_caller
)
2145 scm_c_issue_deprecation_warning
2146 ("`scm_num2long_long' is deprecated. Use scm_to_long_long instead.");
2147 return scm_to_long_long (x
);
2151 scm_num2ulong_long (SCM x
, unsigned long pos
, const char *s_caller
)
2153 scm_c_issue_deprecation_warning
2154 ("`scm_num2ulong_long' is deprecated. Use scm_from_ulong_long instead.");
2155 return scm_to_ulong_long (x
);
2161 scm_make_real (double x
)
2163 scm_c_issue_deprecation_warning
2164 ("`scm_make_real' is deprecated. Use scm_from_double instead.");
2165 return scm_from_double (x
);
2169 scm_num2dbl (SCM a
, const char *why
)
2171 scm_c_issue_deprecation_warning
2172 ("`scm_num2dbl' is deprecated. Use scm_to_double instead.");
2173 return scm_to_double (a
);
2177 scm_float2num (float n
)
2179 scm_c_issue_deprecation_warning
2180 ("`scm_float2num' is deprecated. Use scm_from_double instead.");
2181 return scm_from_double ((double) n
);
2185 scm_double2num (double n
)
2187 scm_c_issue_deprecation_warning
2188 ("`scm_double2num' is deprecated. Use scm_from_double instead.");
2189 return scm_from_double (n
);
2193 scm_make_complex (double x
, double y
)
2195 scm_c_issue_deprecation_warning
2196 ("`scm_make_complex' is deprecated. Use scm_c_make_rectangular instead.");
2197 return scm_c_make_rectangular (x
, y
);
2201 scm_mem2symbol (const char *mem
, size_t len
)
2203 scm_c_issue_deprecation_warning
2204 ("`scm_mem2symbol' is deprecated. Use scm_from_locale_symboln instead.");
2205 return scm_from_locale_symboln (mem
, len
);
2209 scm_mem2uninterned_symbol (const char *mem
, size_t len
)
2211 scm_c_issue_deprecation_warning
2212 ("`scm_mem2uninterned_symbol' is deprecated. "
2213 "Use scm_make_symbol and scm_from_locale_symboln instead.");
2214 return scm_make_symbol (scm_from_locale_stringn (mem
, len
));
2218 scm_str2symbol (const char *str
)
2220 scm_c_issue_deprecation_warning
2221 ("`scm_str2symbol' is deprecated. Use scm_from_locale_symbol instead.");
2222 return scm_from_locale_symbol (str
);
2226 /* This function must only be applied to memory obtained via malloc,
2227 since the GC is going to apply `free' to it when the string is
2230 Also, s[len] must be `\0', since we promise that strings are
2231 null-terminated. Perhaps we could handle non-null-terminated
2232 strings by claiming they're shared substrings of a string we just
2235 scm_take_str (char *s
, size_t len
)
2237 scm_c_issue_deprecation_warning
2238 ("`scm_take_str' is deprecated. Use scm_take_locale_stringn instead.");
2239 return scm_take_locale_stringn (s
, len
);
2242 /* `s' must be a malloc'd string. See scm_take_str. */
2244 scm_take0str (char *s
)
2246 scm_c_issue_deprecation_warning
2247 ("`scm_take0str' is deprecated. Use scm_take_locale_string instead.");
2248 return scm_take_locale_string (s
);
2252 scm_mem2string (const char *src
, size_t len
)
2254 scm_c_issue_deprecation_warning
2255 ("`scm_mem2string' is deprecated. Use scm_from_locale_stringn instead.");
2256 return scm_from_locale_stringn (src
, len
);
2260 scm_str2string (const char *src
)
2262 scm_c_issue_deprecation_warning
2263 ("`scm_str2string' is deprecated. Use scm_from_locale_string instead.");
2264 return scm_from_locale_string (src
);
2268 scm_makfrom0str (const char *src
)
2270 scm_c_issue_deprecation_warning
2271 ("`scm_makfrom0str' is deprecated."
2272 "Use scm_from_locale_string instead, but check for NULL first.");
2273 if (!src
) return SCM_BOOL_F
;
2274 return scm_from_locale_string (src
);
2278 scm_makfrom0str_opt (const char *src
)
2280 scm_c_issue_deprecation_warning
2281 ("`scm_makfrom0str_opt' is deprecated."
2282 "Use scm_from_locale_string instead, but check for NULL first.");
2283 return scm_makfrom0str (src
);
2288 scm_allocate_string (size_t len
)
2290 scm_c_issue_deprecation_warning
2291 ("`scm_allocate_string' is deprecated. Use scm_c_make_string instead.");
2292 return scm_i_make_string (len
, NULL
, 0);
2295 SCM_DEFINE (scm_make_keyword_from_dash_symbol
, "make-keyword-from-dash-symbol", 1, 0, 0,
2297 "Make a keyword object from a @var{symbol} that starts with a dash.")
2298 #define FUNC_NAME s_scm_make_keyword_from_dash_symbol
2300 SCM dash_string
, non_dash_symbol
;
2302 scm_c_issue_deprecation_warning
2303 ("`scm_make_keyword_from_dash_symbol' is deprecated. Don't use dash symbols.");
2305 SCM_ASSERT (scm_is_symbol (symbol
)
2306 && (scm_i_symbol_ref (symbol
, 0) == '-'),
2307 symbol
, SCM_ARG1
, FUNC_NAME
);
2309 dash_string
= scm_symbol_to_string (symbol
);
2311 scm_string_to_symbol (scm_c_substring (dash_string
,
2313 scm_c_string_length (dash_string
)));
2315 return scm_symbol_to_keyword (non_dash_symbol
);
2319 SCM_DEFINE (scm_keyword_dash_symbol
, "keyword-dash-symbol", 1, 0, 0,
2321 "Return the dash symbol for @var{keyword}.\n"
2322 "This is the inverse of @code{make-keyword-from-dash-symbol}.")
2323 #define FUNC_NAME s_scm_keyword_dash_symbol
2325 SCM symbol
= scm_keyword_to_symbol (keyword
);
2326 SCM parts
= scm_list_2 (scm_from_locale_string ("-"),
2327 scm_symbol_to_string (symbol
));
2328 scm_c_issue_deprecation_warning
2329 ("`scm_keyword_dash_symbol' is deprecated. Don't use dash symbols.");
2331 return scm_string_to_symbol (scm_string_append (parts
));
2336 scm_c_make_keyword (const char *s
)
2338 scm_c_issue_deprecation_warning
2339 ("`scm_c_make_keyword' is deprecated. Use scm_from_locale_keyword instead.");
2340 return scm_from_locale_keyword (s
);
2344 scm_thread_sleep (unsigned int t
)
2346 scm_c_issue_deprecation_warning
2347 ("`scm_thread_sleep' is deprecated. Use scm_std_sleep instead.");
2348 return scm_std_sleep (t
);
2352 scm_thread_usleep (unsigned long t
)
2354 scm_c_issue_deprecation_warning
2355 ("`scm_thread_usleep' is deprecated. Use scm_std_usleep instead.");
2356 return scm_std_usleep (t
);
2359 int scm_internal_select (int fds
,
2363 struct timeval
*timeout
)
2365 scm_c_issue_deprecation_warning
2366 ("`scm_internal_select' is deprecated. Use scm_std_select instead.");
2367 return scm_std_select (fds
, rfds
, wfds
, efds
, timeout
);
2374 # if !HAVE_DECL_CUSERID
2375 extern char *cuserid (char *);
2378 SCM_DEFINE (scm_cuserid
, "cuserid", 0, 0, 0,
2380 "Return a string containing a user name associated with the\n"
2381 "effective user id of the process. Return @code{#f} if this\n"
2382 "information cannot be obtained.")
2383 #define FUNC_NAME s_scm_cuserid
2385 char buf
[L_cuserid
];
2388 scm_c_issue_deprecation_warning
2389 ("`cuserid' is deprecated. Use `(passwd:name (getpwuid (geteuid)))' instead.");
2394 return scm_from_locale_string (p
);
2397 #endif /* HAVE_CUSERID */
2404 static SCM properties_whash
;
2406 SCM_DEFINE (scm_primitive_make_property
, "primitive-make-property", 1, 0, 0,
2407 (SCM not_found_proc
),
2408 "Create a @dfn{property token} that can be used with\n"
2409 "@code{primitive-property-ref} and @code{primitive-property-set!}.\n"
2410 "See @code{primitive-property-ref} for the significance of\n"
2411 "@var{not_found_proc}.")
2412 #define FUNC_NAME s_scm_primitive_make_property
2414 scm_c_issue_deprecation_warning
2415 ("`primitive-make-property' is deprecated. Use object properties.");
2417 if (not_found_proc
!= SCM_BOOL_F
)
2418 SCM_VALIDATE_PROC (SCM_ARG1
, not_found_proc
);
2419 return scm_cons (not_found_proc
, SCM_EOL
);
2424 SCM_DEFINE (scm_primitive_property_ref
, "primitive-property-ref", 2, 0, 0,
2425 (SCM prop
, SCM obj
),
2426 "Return the property @var{prop} of @var{obj}.\n"
2428 "When no value has yet been associated with @var{prop} and\n"
2429 "@var{obj}, the @var{not-found-proc} from @var{prop} is used. A\n"
2430 "call @code{(@var{not-found-proc} @var{prop} @var{obj})} is made\n"
2431 "and the result set as the property value. If\n"
2432 "@var{not-found-proc} is @code{#f} then @code{#f} is the\n"
2434 #define FUNC_NAME s_scm_primitive_property_ref
2438 scm_c_issue_deprecation_warning
2439 ("`primitive-property-ref' is deprecated. Use object properties.");
2441 SCM_VALIDATE_CONS (SCM_ARG1
, prop
);
2443 alist
= scm_hashq_ref (properties_whash
, obj
, SCM_EOL
);
2444 if (scm_is_pair (alist
))
2446 SCM assoc
= scm_assq (prop
, alist
);
2447 if (scm_is_true (assoc
))
2448 return SCM_CDR (assoc
);
2451 if (scm_is_false (SCM_CAR (prop
)))
2455 SCM val
= scm_call_2 (SCM_CAR (prop
), prop
, obj
);
2456 scm_hashq_set_x (properties_whash
, obj
,
2457 scm_acons (prop
, val
, alist
));
2464 SCM_DEFINE (scm_primitive_property_set_x
, "primitive-property-set!", 3, 0, 0,
2465 (SCM prop
, SCM obj
, SCM val
),
2466 "Set the property @var{prop} of @var{obj} to @var{val}.")
2467 #define FUNC_NAME s_scm_primitive_property_set_x
2471 scm_c_issue_deprecation_warning
2472 ("`primitive-property-set!' is deprecated. Use object properties.");
2474 SCM_VALIDATE_CONS (SCM_ARG1
, prop
);
2475 alist
= scm_hashq_ref (properties_whash
, obj
, SCM_EOL
);
2476 assoc
= scm_assq (prop
, alist
);
2477 if (scm_is_pair (assoc
))
2478 SCM_SETCDR (assoc
, val
);
2480 scm_hashq_set_x (properties_whash
, obj
,
2481 scm_acons (prop
, val
, alist
));
2482 return SCM_UNSPECIFIED
;
2487 SCM_DEFINE (scm_primitive_property_del_x
, "primitive-property-del!", 2, 0, 0,
2488 (SCM prop
, SCM obj
),
2489 "Remove any value associated with @var{prop} and @var{obj}.")
2490 #define FUNC_NAME s_scm_primitive_property_del_x
2494 scm_c_issue_deprecation_warning
2495 ("`primitive-property-del!' is deprecated. Use object properties.");
2497 SCM_VALIDATE_CONS (SCM_ARG1
, prop
);
2498 alist
= scm_hashq_ref (properties_whash
, obj
, SCM_EOL
);
2499 if (scm_is_pair (alist
))
2500 scm_hashq_set_x (properties_whash
, obj
, scm_assq_remove_x (alist
, prop
));
2501 return SCM_UNSPECIFIED
;
2508 scm_whash_get_handle (SCM whash
, SCM key
)
2510 scm_c_issue_deprecation_warning
2511 ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
2513 return scm_hashq_get_handle (whash
, key
);
2517 SCM_WHASHFOUNDP (SCM h
)
2519 scm_c_issue_deprecation_warning
2520 ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
2522 return scm_is_true (h
);
2526 SCM_WHASHREF (SCM whash
, SCM handle
)
2528 scm_c_issue_deprecation_warning
2529 ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
2531 return SCM_CDR (handle
);
2535 SCM_WHASHSET (SCM whash
, SCM handle
, SCM obj
)
2537 scm_c_issue_deprecation_warning
2538 ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
2540 SCM_SETCDR (handle
, obj
);
2544 scm_whash_create_handle (SCM whash
, SCM key
)
2546 scm_c_issue_deprecation_warning
2547 ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
2549 return scm_hashq_create_handle_x (whash
, key
, SCM_UNSPECIFIED
);
2553 scm_whash_lookup (SCM whash
, SCM obj
)
2555 scm_c_issue_deprecation_warning
2556 ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
2558 return scm_hashq_ref (whash
, obj
, SCM_BOOL_F
);
2562 scm_whash_insert (SCM whash
, SCM key
, SCM obj
)
2564 scm_c_issue_deprecation_warning
2565 ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
2567 scm_hashq_set_x (whash
, key
, obj
);
2572 SCM scm_struct_table
= SCM_BOOL_F
;
2575 scm_struct_create_handle (SCM obj
)
2577 scm_c_issue_deprecation_warning
2578 ("`scm_struct_create_handle' is deprecated, and has no effect.");
2580 return scm_cons (obj
, scm_cons (SCM_BOOL_F
, SCM_BOOL_F
));
2586 scm_internal_dynamic_wind (scm_t_guard before
,
2594 scm_c_issue_deprecation_warning
2595 ("`scm_internal_dynamic_wind' is deprecated. "
2596 "Use the `scm_dynwind_begin' / `scm_dynwind_end' API instead.");
2598 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
2599 scm_dynwind_rewind_handler (before
, guard_data
, SCM_F_WIND_EXPLICITLY
);
2600 scm_dynwind_unwind_handler (after
, guard_data
, SCM_F_WIND_EXPLICITLY
);
2601 ans
= inner (inner_data
);
2609 scm_immutable_cell (scm_t_bits car
, scm_t_bits cdr
)
2611 scm_c_issue_deprecation_warning
2612 ("scm_immutable_cell is deprecated. Use scm_cell instead.");
2614 return scm_cell (car
, cdr
);
2618 scm_immutable_double_cell (scm_t_bits car
, scm_t_bits cbr
,
2619 scm_t_bits ccr
, scm_t_bits cdr
)
2621 scm_c_issue_deprecation_warning
2622 ("scm_immutable_double_cell is deprecated. Use scm_double_cell instead.");
2624 return scm_double_cell (car
, cbr
, ccr
, cdr
);
2631 scm_i_init_deprecated ()
2633 properties_whash
= scm_make_weak_key_hash_table (SCM_UNDEFINED
);
2634 scm_struct_table
= scm_make_hash_table (SCM_UNDEFINED
);
2635 #include "libguile/deprecated.x"