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, 2012, 2013 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
31 #include <arpa/inet.h>
33 #define SCM_BUILDING_DEPRECATED_CODE
35 #include "libguile/_scm.h"
36 #include "libguile/async.h"
37 #include "libguile/arrays.h"
38 #include "libguile/array-map.h"
39 #include "libguile/generalized-arrays.h"
40 #include "libguile/bytevectors.h"
41 #include "libguile/bitvectors.h"
42 #include "libguile/deprecated.h"
43 #include "libguile/deprecation.h"
44 #include "libguile/snarf.h"
45 #include "libguile/validate.h"
46 #include "libguile/strings.h"
47 #include "libguile/srfi-13.h"
48 #include "libguile/modules.h"
49 #include "libguile/eval.h"
50 #include "libguile/smob.h"
51 #include "libguile/procprop.h"
52 #include "libguile/vectors.h"
53 #include "libguile/hashtab.h"
54 #include "libguile/struct.h"
55 #include "libguile/variable.h"
56 #include "libguile/fluids.h"
57 #include "libguile/ports.h"
58 #include "libguile/eq.h"
59 #include "libguile/read.h"
60 #include "libguile/r6rs-ports.h"
61 #include "libguile/strports.h"
62 #include "libguile/smob.h"
63 #include "libguile/alist.h"
64 #include "libguile/keywords.h"
65 #include "libguile/socket.h"
66 #include "libguile/feature.h"
67 #include "libguile/uniform.h"
70 #if (SCM_ENABLE_DEPRECATED == 1)
72 /* From print.c: Internal symbol names of isyms. Deprecated in guile 1.7.0 on
74 char *scm_isymnames
[] =
80 SCM_REGISTER_PROC(s_substring_move_left_x
, "substring-move-left!", 5, 0, 0, scm_substring_move_x
);
82 SCM_REGISTER_PROC(s_substring_move_right_x
, "substring-move-right!", 5, 0, 0, scm_substring_move_x
);
85 scm_wta (SCM arg
, const char *pos
, const char *s_subr
)
87 if (!s_subr
|| !*s_subr
)
89 if ((~0x1fL
) & (long) pos
)
91 /* error string supplied. */
92 scm_misc_error (s_subr
, pos
, scm_list_1 (arg
));
96 /* numerical error code. */
97 scm_t_bits error
= (scm_t_bits
) pos
;
102 scm_wrong_type_arg (s_subr
, 0, arg
);
104 scm_wrong_type_arg (s_subr
, 1, arg
);
106 scm_wrong_type_arg (s_subr
, 2, arg
);
108 scm_wrong_type_arg (s_subr
, 3, arg
);
110 scm_wrong_type_arg (s_subr
, 4, arg
);
112 scm_wrong_type_arg (s_subr
, 5, arg
);
114 scm_wrong_type_arg (s_subr
, 6, arg
);
116 scm_wrong_type_arg (s_subr
, 7, arg
);
118 scm_wrong_num_args (arg
);
120 scm_out_of_range (s_subr
, arg
);
122 scm_memory_error (s_subr
);
124 /* this shouldn't happen. */
125 scm_misc_error (s_subr
, "Unknown error", SCM_EOL
);
128 return SCM_UNSPECIFIED
;
134 /* We can't use SCM objects here. One should be able to call
135 SCM_REGISTER_MODULE from a C++ constructor for a static
136 object. This happens before main and thus before libguile is
140 struct moddata
*link
;
145 static struct moddata
*registered_mods
= NULL
;
148 scm_register_module_xxx (char *module_name
, void *init_func
)
152 scm_c_issue_deprecation_warning
153 ("`scm_register_module_xxx' is deprecated. Use extensions instead.");
155 /* XXX - should we (and can we) DEFER_INTS here? */
157 for (md
= registered_mods
; md
; md
= md
->link
)
158 if (!strcmp (md
->module_name
, module_name
))
160 md
->init_func
= init_func
;
164 md
= (struct moddata
*) malloc (sizeof (struct moddata
));
168 "guile: can't register module (%s): not enough memory",
173 md
->module_name
= module_name
;
174 md
->init_func
= init_func
;
175 md
->link
= registered_mods
;
176 registered_mods
= md
;
179 SCM_DEFINE (scm_registered_modules
, "c-registered-modules", 0, 0, 0,
181 "Return a list of the object code modules that have been imported into\n"
182 "the current Guile process. Each element of the list is a pair whose\n"
183 "car is the name of the module, and whose cdr is the function handle\n"
184 "for that module's initializer function. The name is the string that\n"
185 "has been passed to scm_register_module_xxx.")
186 #define FUNC_NAME s_scm_registered_modules
192 for (md
= registered_mods
; md
; md
= md
->link
)
193 res
= scm_cons (scm_cons (scm_from_locale_string (md
->module_name
),
194 scm_from_ulong ((unsigned long) md
->init_func
)),
200 SCM_DEFINE (scm_clear_registered_modules
, "c-clear-registered-modules", 0, 0, 0,
202 "Destroy the list of modules registered with the current Guile process.\n"
203 "The return value is unspecified. @strong{Warning:} this function does\n"
204 "not actually unlink or deallocate these modules, but only destroys the\n"
205 "records of which modules have been loaded. It should therefore be used\n"
206 "only by module bookkeeping operations.")
207 #define FUNC_NAME s_scm_clear_registered_modules
209 struct moddata
*md1
, *md2
;
211 SCM_CRITICAL_SECTION_START
;
213 for (md1
= registered_mods
; md1
; md1
= md2
)
218 registered_mods
= NULL
;
220 SCM_CRITICAL_SECTION_END
;
221 return SCM_UNSPECIFIED
;
226 scm_remember (SCM
*ptr
)
228 scm_c_issue_deprecation_warning ("`scm_remember' is deprecated. "
229 "Use the `scm_remember_upto_here*' family of functions instead.");
233 scm_protect_object (SCM obj
)
235 scm_c_issue_deprecation_warning ("`scm_protect_object' is deprecated. "
236 "Use `scm_gc_protect_object' instead.");
237 return scm_gc_protect_object (obj
);
241 scm_unprotect_object (SCM obj
)
243 scm_c_issue_deprecation_warning ("`scm_unprotect_object' is deprecated. "
244 "Use `scm_gc_unprotect_object' instead.");
245 return scm_gc_unprotect_object (obj
);
248 SCM_SYMBOL (scm_sym_app
, "app");
249 SCM_SYMBOL (scm_sym_modules
, "modules");
250 static SCM module_prefix
= SCM_BOOL_F
;
251 static SCM make_modules_in_var
;
252 static SCM beautify_user_module_x_var
;
253 static SCM try_module_autoload_var
;
258 if (scm_is_false (module_prefix
))
260 module_prefix
= scm_list_2 (scm_sym_app
, scm_sym_modules
);
261 make_modules_in_var
= scm_c_lookup ("make-modules-in");
262 beautify_user_module_x_var
=
263 scm_c_lookup ("beautify-user-module!");
264 try_module_autoload_var
= scm_c_lookup ("try-module-autoload");
269 scm_module_full_name (SCM name
)
271 init_module_stuff ();
272 if (scm_is_eq (SCM_CAR (name
), scm_sym_app
))
275 return scm_append (scm_list_2 (module_prefix
, name
));
279 scm_make_module (SCM name
)
281 init_module_stuff ();
282 scm_c_issue_deprecation_warning ("`scm_make_module' is deprecated. "
283 "Use `scm_c_define_module instead.");
285 return scm_call_2 (SCM_VARIABLE_REF (make_modules_in_var
),
286 scm_the_root_module (),
287 scm_module_full_name (name
));
291 scm_ensure_user_module (SCM module
)
293 init_module_stuff ();
294 scm_c_issue_deprecation_warning ("`scm_ensure_user_module' is deprecated. "
295 "Use `scm_c_define_module instead.");
297 scm_call_1 (SCM_VARIABLE_REF (beautify_user_module_x_var
), module
);
298 return SCM_UNSPECIFIED
;
302 scm_load_scheme_module (SCM name
)
304 init_module_stuff ();
305 scm_c_issue_deprecation_warning ("`scm_load_scheme_module' is deprecated. "
306 "Use `scm_c_resolve_module instead.");
308 return scm_call_1 (SCM_VARIABLE_REF (try_module_autoload_var
), name
);
311 /* This is implemented in C solely for SCM_COERCE_OUTPORT ... */
314 maybe_close_port (void *data
, SCM port
)
316 SCM except_set
= PTR2SCM (data
);
318 while (!scm_is_null (except_set
))
320 SCM p
= SCM_COERCE_OUTPORT (SCM_CAR (except_set
));
321 if (scm_is_eq (p
, port
))
323 except_set
= SCM_CDR (except_set
);
326 scm_close_port (port
);
329 SCM_DEFINE (scm_close_all_ports_except
, "close-all-ports-except", 0, 0, 1,
331 "[DEPRECATED] Close all open file ports used by the interpreter\n"
332 "except for those supplied as arguments. This procedure\n"
333 "was intended to be used before an exec call to close file descriptors\n"
334 "which are not needed in the new process. However it has the\n"
335 "undesirable side effect of flushing buffers, so it's deprecated.\n"
336 "Use port-for-each instead.")
337 #define FUNC_NAME s_scm_close_all_ports_except
340 SCM_VALIDATE_REST_ARGUMENT (ports
);
342 for (p
= ports
; !scm_is_null (p
); p
= SCM_CDR (p
))
343 SCM_VALIDATE_OPPORT (SCM_ARG1
, SCM_COERCE_OUTPORT (SCM_CAR (p
)));
345 scm_c_port_for_each (maybe_close_port
, SCM2PTR (ports
));
347 return SCM_UNSPECIFIED
;
351 SCM_DEFINE (scm_variable_set_name_hint
, "variable-set-name-hint!", 2, 0, 0,
353 "Do not use this function.")
354 #define FUNC_NAME s_scm_variable_set_name_hint
356 SCM_VALIDATE_VARIABLE (1, var
);
357 SCM_VALIDATE_SYMBOL (2, hint
);
358 scm_c_issue_deprecation_warning
359 ("'variable-set-name-hint!' is deprecated. Do not use it.");
360 return SCM_UNSPECIFIED
;
364 SCM_DEFINE (scm_builtin_variable
, "builtin-variable", 1, 0, 0,
366 "Do not use this function.")
367 #define FUNC_NAME s_scm_builtin_variable
369 SCM_VALIDATE_SYMBOL (1,name
);
370 scm_c_issue_deprecation_warning ("`builtin-variable' is deprecated. "
371 "Use module system operations instead.");
372 return scm_sym2var (name
, SCM_BOOL_F
, SCM_BOOL_T
);
377 scm_makstr (size_t len
, int dummy
)
379 scm_c_issue_deprecation_warning
380 ("'scm_makstr' is deprecated. Use 'scm_c_make_string' instead.");
381 return scm_c_make_string (len
, SCM_UNDEFINED
);
385 scm_makfromstr (const char *src
, size_t len
, int dummy SCM_UNUSED
)
387 scm_c_issue_deprecation_warning ("`scm_makfromstr' is deprecated. "
388 "Use `scm_from_locale_stringn' instead.");
390 return scm_from_locale_stringn (src
, len
);
394 scm_internal_with_fluids (SCM fluids
, SCM values
, SCM (*cproc
) (), void *cdata
)
396 scm_c_issue_deprecation_warning ("`scm_internal_with_fluids' is deprecated. "
397 "Use `scm_c_with_fluids' instead.");
399 return scm_c_with_fluids (fluids
, values
, cproc
, cdata
);
403 scm_make_gsubr (const char *name
, int req
, int opt
, int rst
, SCM (*fcn
)())
405 scm_c_issue_deprecation_warning
406 ("`scm_make_gsubr' is deprecated. Use `scm_c_define_gsubr' instead.");
408 return scm_c_define_gsubr (name
, req
, opt
, rst
, fcn
);
412 scm_make_gsubr_with_generic (const char *name
,
413 int req
, int opt
, int rst
,
414 SCM (*fcn
)(), SCM
*gf
)
416 scm_c_issue_deprecation_warning
417 ("`scm_make_gsubr_with_generic' is deprecated. "
418 "Use `scm_c_define_gsubr_with_generic' instead.");
420 return scm_c_define_gsubr_with_generic (name
, req
, opt
, rst
, fcn
, gf
);
424 scm_create_hook (const char *name
, int n_args
)
426 scm_c_issue_deprecation_warning
427 ("'scm_create_hook' is deprecated. "
428 "Use 'scm_make_hook' and 'scm_c_define' instead.");
430 SCM hook
= scm_make_hook (scm_from_int (n_args
));
431 scm_c_define (name
, hook
);
436 SCM_DEFINE (scm_sloppy_memq
, "sloppy-memq", 2, 0, 0,
438 "This procedure behaves like @code{memq}, but does no type or error checking.\n"
439 "Its use is recommended only in writing Guile internals,\n"
440 "not for high-level Scheme programs.")
441 #define FUNC_NAME s_scm_sloppy_memq
443 scm_c_issue_deprecation_warning
444 ("'sloppy-memq' is deprecated. Use 'memq' instead.");
446 for(; scm_is_pair (lst
); lst
= SCM_CDR(lst
))
448 if (scm_is_eq (SCM_CAR (lst
), x
))
456 SCM_DEFINE (scm_sloppy_memv
, "sloppy-memv", 2, 0, 0,
458 "This procedure behaves like @code{memv}, but does no type or error checking.\n"
459 "Its use is recommended only in writing Guile internals,\n"
460 "not for high-level Scheme programs.")
461 #define FUNC_NAME s_scm_sloppy_memv
463 scm_c_issue_deprecation_warning
464 ("'sloppy-memv' is deprecated. Use 'memv' instead.");
466 for(; scm_is_pair (lst
); lst
= SCM_CDR(lst
))
468 if (! scm_is_false (scm_eqv_p (SCM_CAR (lst
), x
)))
476 SCM_DEFINE (scm_sloppy_member
, "sloppy-member", 2, 0, 0,
478 "This procedure behaves like @code{member}, but does no type or error checking.\n"
479 "Its use is recommended only in writing Guile internals,\n"
480 "not for high-level Scheme programs.")
481 #define FUNC_NAME s_scm_sloppy_member
483 scm_c_issue_deprecation_warning
484 ("'sloppy-member' is deprecated. Use 'member' instead.");
486 for(; scm_is_pair (lst
); lst
= SCM_CDR(lst
))
488 if (! scm_is_false (scm_equal_p (SCM_CAR (lst
), x
)))
495 SCM_SYMBOL (scm_end_of_file_key
, "end-of-file");
497 SCM_DEFINE (scm_read_and_eval_x
, "read-and-eval!", 0, 1, 0,
499 "Read a form from @var{port} (standard input by default), and evaluate it\n"
500 "(memoizing it in the process) in the top-level environment. If no data\n"
501 "is left to be read from @var{port}, an @code{end-of-file} error is\n"
503 #define FUNC_NAME s_scm_read_and_eval_x
507 scm_c_issue_deprecation_warning
508 ("'read-and-eval!' is deprecated. Use 'read' and 'eval' instead.");
510 form
= scm_read (port
);
511 if (SCM_EOF_OBJECT_P (form
))
512 scm_ithrow (scm_end_of_file_key
, SCM_EOL
, 1);
513 return scm_eval_x (form
, scm_current_module ());
517 /* Call thunk(closure) underneath a top-level error handler.
518 * If an error occurs, pass the exitval through err_filter and return it.
519 * If no error occurs, return the value of thunk.
523 typedef int setjmp_type
;
525 typedef long setjmp_type
;
528 struct cce_handler_data
{
529 SCM (*err_filter
) ();
534 invoke_err_filter (void *d
, SCM tag
, SCM args
)
536 struct cce_handler_data
*data
= (struct cce_handler_data
*)d
;
537 return data
->err_filter (SCM_BOOL_F
, data
->closure
);
541 scm_call_catching_errors (SCM (*thunk
)(), SCM (*err_filter
)(), void *closure
)
543 scm_c_issue_deprecation_warning
544 ("'scm_call_catching_errors' is deprecated. "
545 "Use 'scm_internal_catch' instead.");
548 struct cce_handler_data data
;
549 data
.err_filter
= err_filter
;
550 data
.closure
= closure
;
551 return scm_internal_catch (SCM_BOOL_T
,
552 (scm_t_catch_body
)thunk
, closure
,
553 (scm_t_catch_handler
)invoke_err_filter
, &data
);
558 scm_make_smob_type_mfpe (char *name
, size_t size
,
560 size_t (*free
) (SCM
),
561 int (*print
) (SCM
, SCM
, scm_print_state
*),
562 SCM (*equalp
) (SCM
, SCM
))
564 scm_c_issue_deprecation_warning
565 ("'scm_make_smob_type_mfpe' is deprecated. "
566 "Use 'scm_make_smob_type' plus 'scm_set_smob_*' instead.");
569 long answer
= scm_make_smob_type (name
, size
);
570 scm_set_smob_mfpe (answer
, mark
, free
, print
, equalp
);
576 scm_set_smob_mfpe (long tc
,
578 size_t (*free
) (SCM
),
579 int (*print
) (SCM
, SCM
, scm_print_state
*),
580 SCM (*equalp
) (SCM
, SCM
))
582 scm_c_issue_deprecation_warning
583 ("'scm_set_smob_mfpe' is deprecated. "
584 "Use 'scm_set_smob_mark' instead, for example.");
586 if (mark
) scm_set_smob_mark (tc
, mark
);
587 if (free
) scm_set_smob_free (tc
, free
);
588 if (print
) scm_set_smob_print (tc
, print
);
589 if (equalp
) scm_set_smob_equalp (tc
, equalp
);
593 scm_smob_free (SCM obj
)
595 long n
= SCM_SMOBNUM (obj
);
597 scm_c_issue_deprecation_warning
598 ("`scm_smob_free' is deprecated. "
599 "It is no longer needed.");
601 if (scm_smobs
[n
].size
> 0)
602 scm_gc_free ((void *) SCM_SMOB_DATA_1 (obj
),
603 scm_smobs
[n
].size
, SCM_SMOBNAME (n
));
608 scm_read_0str (char *expr
)
610 scm_c_issue_deprecation_warning
611 ("scm_read_0str is deprecated. Use scm_c_read_string instead.");
613 return scm_c_read_string (expr
);
617 scm_eval_0str (const char *expr
)
619 scm_c_issue_deprecation_warning
620 ("scm_eval_0str is deprecated. Use scm_c_eval_string instead.");
622 return scm_c_eval_string (expr
);
626 scm_strprint_obj (SCM obj
)
628 scm_c_issue_deprecation_warning
629 ("scm_strprint_obj is deprecated. Use scm_object_to_string instead.");
630 return scm_object_to_string (obj
, SCM_UNDEFINED
);
634 scm_i_object_chars (SCM obj
)
636 scm_c_issue_deprecation_warning
637 ("SCM_CHARS is deprecated. See the manual for alternatives.");
638 if (SCM_STRINGP (obj
))
639 return SCM_STRING_CHARS (obj
);
640 if (SCM_SYMBOLP (obj
))
641 return SCM_SYMBOL_CHARS (obj
);
646 scm_i_object_length (SCM obj
)
648 scm_c_issue_deprecation_warning
649 ("SCM_LENGTH is deprecated. "
650 "Use scm_c_string_length instead, for example, or see the manual.");
651 if (SCM_STRINGP (obj
))
652 return SCM_STRING_LENGTH (obj
);
653 if (SCM_SYMBOLP (obj
))
654 return SCM_SYMBOL_LENGTH (obj
);
655 if (SCM_VECTORP (obj
))
656 return SCM_VECTOR_LENGTH (obj
);
661 scm_sym2ovcell_soft (SCM sym
, SCM obarray
)
664 size_t hash
= scm_i_symbol_hash (sym
) % SCM_VECTOR_LENGTH (obarray
);
666 scm_c_issue_deprecation_warning ("`scm_sym2ovcell_soft' is deprecated. "
667 "Use hashtables instead.");
669 SCM_CRITICAL_SECTION_START
;
670 for (lsym
= SCM_VECTOR_REF (obarray
, hash
);
672 lsym
= SCM_CDR (lsym
))
675 if (scm_is_eq (SCM_CAR (z
), sym
))
677 SCM_CRITICAL_SECTION_END
;
681 SCM_CRITICAL_SECTION_END
;
687 scm_sym2ovcell (SCM sym
, SCM obarray
)
688 #define FUNC_NAME "scm_sym2ovcell"
692 scm_c_issue_deprecation_warning ("`scm_sym2ovcell' is deprecated. "
693 "Use hashtables instead.");
695 answer
= scm_sym2ovcell_soft (sym
, obarray
);
696 if (scm_is_true (answer
))
698 SCM_MISC_ERROR ("uninterned symbol: ~S", scm_list_1 (sym
));
699 return SCM_UNSPECIFIED
; /* not reached */
704 /* Intern a symbol whose name is the LEN characters at NAME in OBARRAY.
706 OBARRAY should be a vector of lists, indexed by the name's hash
707 value, modulo OBARRAY's length. Each list has the form
708 ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the
709 value associated with that symbol (in the current module? in the
712 To "intern" a symbol means: if OBARRAY already contains a symbol by
713 that name, return its (SYMBOL . VALUE) pair; otherwise, create a
714 new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the
715 appropriate list of the OBARRAY, and return the pair.
717 If softness is non-zero, don't create a symbol if it isn't already
718 in OBARRAY; instead, just return #f.
720 If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and
721 return (SYMBOL . SCM_UNDEFINED). */
725 intern_obarray_soft (SCM symbol
, SCM obarray
, unsigned int softness
)
727 size_t raw_hash
= scm_i_symbol_hash (symbol
);
731 if (scm_is_false (obarray
))
736 return scm_cons (symbol
, SCM_UNDEFINED
);
739 hash
= raw_hash
% SCM_VECTOR_LENGTH (obarray
);
741 for (lsym
= SCM_VECTOR_REF(obarray
, hash
);
742 SCM_NIMP (lsym
); lsym
= SCM_CDR (lsym
))
744 SCM a
= SCM_CAR (lsym
);
746 if (scm_is_eq (z
, symbol
))
756 SCM cell
= scm_cons (symbol
, SCM_UNDEFINED
);
757 SCM slot
= SCM_VECTOR_REF (obarray
, hash
);
759 SCM_VECTOR_SET (obarray
, hash
, scm_cons (cell
, slot
));
767 scm_intern_obarray_soft (const char *name
, size_t len
, SCM obarray
,
768 unsigned int softness
)
770 SCM symbol
= scm_from_locale_symboln (name
, len
);
772 scm_c_issue_deprecation_warning ("`scm_intern_obarray_soft' is deprecated. "
773 "Use hashtables instead.");
775 return intern_obarray_soft (symbol
, obarray
, softness
);
779 scm_intern_obarray (const char *name
,size_t len
,SCM obarray
)
781 scm_c_issue_deprecation_warning ("`scm_intern_obarray' is deprecated. "
782 "Use hashtables instead.");
784 return scm_intern_obarray_soft (name
, len
, obarray
, 0);
787 /* Lookup the value of the symbol named by the nul-terminated string
788 NAME in the current module. */
790 scm_symbol_value0 (const char *name
)
792 scm_c_issue_deprecation_warning ("`scm_symbol_value0' is deprecated. "
793 "Use `scm_lookup' instead.");
795 return scm_variable_ref (scm_c_lookup (name
));
798 SCM_DEFINE (scm_string_to_obarray_symbol
, "string->obarray-symbol", 2, 1, 0,
799 (SCM o
, SCM s
, SCM softp
),
800 "Intern a new symbol in @var{obarray}, a symbol table, with name\n"
802 "If @var{obarray} is @code{#f}, use the default system symbol table. If\n"
803 "@var{obarray} is @code{#t}, the symbol should not be interned in any\n"
804 "symbol table; merely return the pair (@var{symbol}\n"
805 ". @var{#<undefined>}).\n\n"
806 "The @var{soft?} argument determines whether new symbol table entries\n"
807 "should be created when the specified symbol is not already present in\n"
808 "@var{obarray}. If @var{soft?} is specified and is a true value, then\n"
809 "new entries should not be added for symbols not already present in the\n"
810 "table; instead, simply return @code{#f}.")
811 #define FUNC_NAME s_scm_string_to_obarray_symbol
817 SCM_VALIDATE_STRING (2, s
);
818 SCM_ASSERT (scm_is_bool (o
) || SCM_VECTORP (o
), o
, SCM_ARG1
, FUNC_NAME
);
820 scm_c_issue_deprecation_warning ("`string->obarray-symbol' is deprecated. "
821 "Use hashtables instead.");
823 softness
= (!SCM_UNBNDP (softp
) && scm_is_true(softp
));
824 /* iron out some screwy calling conventions */
825 if (scm_is_false (o
))
827 /* nothing interesting to do here. */
828 return scm_string_to_symbol (s
);
830 else if (scm_is_eq (o
, SCM_BOOL_T
))
833 vcell
= intern_obarray_soft (scm_string_to_symbol (s
), o
, softness
);
834 if (scm_is_false (vcell
))
836 answer
= SCM_CAR (vcell
);
841 SCM_DEFINE (scm_intern_symbol
, "intern-symbol", 2, 0, 0,
843 "Add a new symbol to @var{obarray} with name @var{string}, bound to an\n"
844 "unspecified initial value. The symbol table is not modified if a symbol\n"
845 "with this name is already present.")
846 #define FUNC_NAME s_scm_intern_symbol
849 SCM_VALIDATE_SYMBOL (2,s
);
850 if (scm_is_false (o
))
851 return SCM_UNSPECIFIED
;
853 scm_c_issue_deprecation_warning ("`intern-symbol' is deprecated. "
854 "Use hashtables instead.");
856 SCM_VALIDATE_VECTOR (1,o
);
857 hval
= scm_i_symbol_hash (s
) % SCM_VECTOR_LENGTH (o
);
858 /* If the symbol is already interned, simply return. */
859 SCM_CRITICAL_SECTION_START
;
863 for (lsym
= SCM_VECTOR_REF (o
, hval
);
865 lsym
= SCM_CDR (lsym
))
867 sym
= SCM_CAR (lsym
);
868 if (scm_is_eq (SCM_CAR (sym
), s
))
870 SCM_CRITICAL_SECTION_END
;
871 return SCM_UNSPECIFIED
;
874 SCM_VECTOR_SET (o
, hval
,
875 scm_acons (s
, SCM_UNDEFINED
,
876 SCM_VECTOR_REF (o
, hval
)));
878 SCM_CRITICAL_SECTION_END
;
879 return SCM_UNSPECIFIED
;
883 SCM_DEFINE (scm_unintern_symbol
, "unintern-symbol", 2, 0, 0,
885 "Remove the symbol with name @var{string} from @var{obarray}. This\n"
886 "function returns @code{#t} if the symbol was present and @code{#f}\n"
888 #define FUNC_NAME s_scm_unintern_symbol
892 scm_c_issue_deprecation_warning ("`unintern-symbol' is deprecated. "
893 "Use hashtables instead.");
895 SCM_VALIDATE_SYMBOL (2,s
);
896 if (scm_is_false (o
))
898 SCM_VALIDATE_VECTOR (1,o
);
899 hval
= scm_i_symbol_hash (s
) % SCM_VECTOR_LENGTH (o
);
900 SCM_CRITICAL_SECTION_START
;
905 for (lsym
= SCM_VECTOR_REF (o
, hval
), lsym_follow
= SCM_BOOL_F
;
907 lsym_follow
= lsym
, lsym
= SCM_CDR (lsym
))
909 sym
= SCM_CAR (lsym
);
910 if (scm_is_eq (SCM_CAR (sym
), s
))
912 /* Found the symbol to unintern. */
913 if (scm_is_false (lsym_follow
))
914 SCM_VECTOR_SET (o
, hval
, lsym
);
916 SCM_SETCDR (lsym_follow
, SCM_CDR(lsym
));
917 SCM_CRITICAL_SECTION_END
;
922 SCM_CRITICAL_SECTION_END
;
927 SCM_DEFINE (scm_symbol_binding
, "symbol-binding", 2, 0, 0,
929 "Look up in @var{obarray} the symbol whose name is @var{string}, and\n"
930 "return the value to which it is bound. If @var{obarray} is @code{#f},\n"
931 "use the global symbol table. If @var{string} is not interned in\n"
932 "@var{obarray}, an error is signalled.")
933 #define FUNC_NAME s_scm_symbol_binding
937 scm_c_issue_deprecation_warning ("`symbol-binding' is deprecated. "
938 "Use hashtables instead.");
940 SCM_VALIDATE_SYMBOL (2,s
);
941 if (scm_is_false (o
))
942 return scm_variable_ref (scm_lookup (s
));
943 SCM_VALIDATE_VECTOR (1,o
);
944 vcell
= scm_sym2ovcell (s
, o
);
945 return SCM_CDR(vcell
);
950 SCM_DEFINE (scm_symbol_interned_p
, "symbol-interned?", 2, 0, 0,
952 "Return @code{#t} if @var{obarray} contains a symbol with name\n"
953 "@var{string}, and @code{#f} otherwise.")
954 #define FUNC_NAME s_scm_symbol_interned_p
958 scm_c_issue_deprecation_warning ("`symbol-interned?' is deprecated. "
959 "Use hashtables instead.");
961 SCM_VALIDATE_SYMBOL (2,s
);
962 if (scm_is_false (o
))
964 SCM var
= scm_sym2var (s
, SCM_BOOL_F
, SCM_BOOL_F
);
965 if (var
!= SCM_BOOL_F
)
969 SCM_VALIDATE_VECTOR (1,o
);
970 vcell
= scm_sym2ovcell_soft (s
, o
);
971 return (SCM_NIMP(vcell
)
978 SCM_DEFINE (scm_symbol_bound_p
, "symbol-bound?", 2, 0, 0,
980 "Return @code{#t} if @var{obarray} contains a symbol with name\n"
981 "@var{string} bound to a defined value. This differs from\n"
982 "@var{symbol-interned?} in that the mere mention of a symbol\n"
983 "usually causes it to be interned; @code{symbol-bound?}\n"
984 "determines whether a symbol has been given any meaningful\n"
986 #define FUNC_NAME s_scm_symbol_bound_p
990 scm_c_issue_deprecation_warning ("`symbol-bound?' is deprecated. "
991 "Use hashtables instead.");
993 SCM_VALIDATE_SYMBOL (2,s
);
994 if (scm_is_false (o
))
996 SCM var
= scm_sym2var (s
, SCM_BOOL_F
, SCM_BOOL_F
);
997 if (SCM_VARIABLEP(var
) && !SCM_UNBNDP(SCM_VARIABLE_REF(var
)))
1001 SCM_VALIDATE_VECTOR (1,o
);
1002 vcell
= scm_sym2ovcell_soft (s
, o
);
1003 return scm_from_bool (SCM_NIMP (vcell
) && !SCM_UNBNDP (SCM_CDR (vcell
)));
1008 SCM_DEFINE (scm_symbol_set_x
, "symbol-set!", 3, 0, 0,
1009 (SCM o
, SCM s
, SCM v
),
1010 "Find the symbol in @var{obarray} whose name is @var{string}, and rebind\n"
1011 "it to @var{value}. An error is signalled if @var{string} is not present\n"
1012 "in @var{obarray}.")
1013 #define FUNC_NAME s_scm_symbol_set_x
1017 scm_c_issue_deprecation_warning ("`symbol-set!' is deprecated. "
1018 "Use the module system instead.");
1020 SCM_VALIDATE_SYMBOL (2,s
);
1021 if (scm_is_false (o
))
1024 return SCM_UNSPECIFIED
;
1026 SCM_VALIDATE_VECTOR (1,o
);
1027 vcell
= scm_sym2ovcell (s
, o
);
1028 SCM_SETCDR (vcell
, v
);
1029 return SCM_UNSPECIFIED
;
1033 #define MAX_PREFIX_LENGTH 30
1035 static int gentemp_counter
;
1037 SCM_DEFINE (scm_gentemp
, "gentemp", 0, 2, 0,
1038 (SCM prefix
, SCM obarray
),
1039 "Create a new symbol with a name unique in an obarray.\n"
1040 "The name is constructed from an optional string @var{prefix}\n"
1041 "and a counter value. The default prefix is @code{t}. The\n"
1042 "@var{obarray} is specified as a second optional argument.\n"
1043 "Default is the system obarray where all normal symbols are\n"
1044 "interned. The counter is increased by 1 at each\n"
1045 "call. There is no provision for resetting the counter.")
1046 #define FUNC_NAME s_scm_gentemp
1048 char buf
[MAX_PREFIX_LENGTH
+ SCM_INTBUFLEN
];
1053 scm_c_issue_deprecation_warning ("`gentemp' is deprecated. "
1054 "Use `gensym' instead.");
1056 if (SCM_UNBNDP (prefix
))
1063 SCM_VALIDATE_STRING (1, prefix
);
1064 len
= scm_i_string_length (prefix
);
1065 name
= scm_to_locale_stringn (prefix
, &len
);
1066 name
= scm_realloc (name
, len
+ SCM_INTBUFLEN
);
1069 if (SCM_UNBNDP (obarray
))
1070 return scm_gensym (prefix
);
1072 SCM_ASSERT ((scm_is_vector (obarray
) || SCM_I_WVECTP (obarray
)),
1077 n_digits
= scm_iint2str (gentemp_counter
++, 10, &name
[len
]);
1078 while (scm_is_true (scm_intern_obarray_soft (name
,
1083 SCM vcell
= scm_intern_obarray_soft (name
,
1089 return SCM_CAR (vcell
);
1095 scm_i_makinum (scm_t_signed_bits val
)
1097 scm_c_issue_deprecation_warning
1098 ("SCM_MAKINUM is deprecated. Use scm_from_int or similar instead.");
1099 return SCM_I_MAKINUM (val
);
1103 scm_i_inump (SCM obj
)
1105 scm_c_issue_deprecation_warning
1106 ("SCM_INUMP is deprecated. Use scm_is_integer or similar instead.");
1107 return SCM_I_INUMP (obj
);
1111 scm_i_inum (SCM obj
)
1113 scm_c_issue_deprecation_warning
1114 ("SCM_INUM is deprecated. Use scm_to_int or similar instead.");
1115 return scm_to_intmax (obj
);
1119 scm_c_string2str (SCM obj
, char *str
, size_t *lenp
)
1121 scm_c_issue_deprecation_warning
1122 ("scm_c_string2str is deprecated. Use scm_to_locale_stringbuf or similar instead.");
1126 char *result
= scm_to_locale_string (obj
);
1128 *lenp
= scm_i_string_length (obj
);
1133 /* Pray that STR is large enough.
1135 size_t len
= scm_to_locale_stringbuf (obj
, str
, SCM_I_SIZE_MAX
);
1144 scm_c_substring2str (SCM obj
, char *str
, size_t start
, size_t len
)
1146 scm_c_issue_deprecation_warning
1147 ("scm_c_substring2str is deprecated. Use scm_substring plus scm_to_locale_stringbuf instead.");
1150 obj
= scm_substring (obj
, scm_from_size_t (start
), SCM_UNDEFINED
);
1152 scm_to_locale_stringbuf (obj
, str
, len
);
1156 /* Converts the given Scheme symbol OBJ into a C string, containing a copy
1157 of OBJ's content with a trailing null byte. If LENP is non-NULL, set
1158 *LENP to the string's length.
1160 When STR is non-NULL it receives the copy and is returned by the function,
1161 otherwise new memory is allocated and the caller is responsible for
1162 freeing it via free(). If out of memory, NULL is returned.
1164 Note that Scheme symbols may contain arbitrary data, including null
1165 characters. This means that null termination is not a reliable way to
1166 determine the length of the returned value. However, the function always
1167 copies the complete contents of OBJ, and sets *LENP to the length of the
1168 scheme symbol (if LENP is non-null). */
1170 scm_c_symbol2str (SCM obj
, char *str
, size_t *lenp
)
1172 return scm_c_string2str (scm_symbol_to_string (obj
), str
, lenp
);
1176 scm_truncate (double x
)
1178 scm_c_issue_deprecation_warning
1179 ("scm_truncate is deprecated. Use scm_c_truncate instead.");
1180 return scm_c_truncate (x
);
1184 scm_round (double x
)
1186 scm_c_issue_deprecation_warning
1187 ("scm_round is deprecated. Use scm_c_round instead.");
1188 return scm_c_round (x
);
1192 scm_sys_expt (SCM x
, SCM y
)
1194 scm_c_issue_deprecation_warning
1195 ("scm_sys_expt is deprecated. Use scm_expt instead.");
1196 return scm_expt (x
, y
);
1200 scm_asinh (double x
)
1202 scm_c_issue_deprecation_warning
1203 ("scm_asinh is deprecated. Use asinh instead.");
1207 return log (x
+ sqrt (x
* x
+ 1));
1212 scm_acosh (double x
)
1214 scm_c_issue_deprecation_warning
1215 ("scm_acosh is deprecated. Use acosh instead.");
1219 return log (x
+ sqrt (x
* x
- 1));
1224 scm_atanh (double x
)
1226 scm_c_issue_deprecation_warning
1227 ("scm_atanh is deprecated. Use atanh instead.");
1231 return 0.5 * log ((1 + x
) / (1 - x
));
1236 scm_sys_atan2 (SCM z1
, SCM z2
)
1238 scm_c_issue_deprecation_warning
1239 ("scm_sys_atan2 is deprecated. Use scm_atan instead.");
1240 return scm_atan (z1
, z2
);
1244 scm_i_deprecated_symbol_chars (SCM sym
)
1246 scm_c_issue_deprecation_warning
1247 ("SCM_SYMBOL_CHARS is deprecated. Use scm_symbol_to_string.");
1249 return (char *)scm_i_symbol_chars (sym
);
1253 scm_i_deprecated_symbol_length (SCM sym
)
1255 scm_c_issue_deprecation_warning
1256 ("SCM_SYMBOL_LENGTH is deprecated. Use scm_symbol_to_string.");
1257 return scm_i_symbol_length (sym
);
1261 scm_i_keywordp (SCM obj
)
1263 scm_c_issue_deprecation_warning
1264 ("SCM_KEYWORDP is deprecated. Use scm_is_keyword instead.");
1265 return scm_is_keyword (obj
);
1269 scm_i_keywordsym (SCM keyword
)
1271 scm_c_issue_deprecation_warning
1272 ("SCM_KEYWORDSYM is deprecated. See scm_keyword_to_symbol instead.");
1273 return scm_keyword_dash_symbol (keyword
);
1277 scm_i_vectorp (SCM x
)
1279 scm_c_issue_deprecation_warning
1280 ("SCM_VECTORP is deprecated. Use scm_is_vector instead.");
1281 return SCM_I_IS_VECTOR (x
);
1285 scm_i_vector_length (SCM x
)
1287 scm_c_issue_deprecation_warning
1288 ("SCM_VECTOR_LENGTH is deprecated. Use scm_c_vector_length instead.");
1289 return SCM_I_VECTOR_LENGTH (x
);
1295 scm_c_issue_deprecation_warning
1296 ("SCM_VELTS is deprecated. Use scm_vector_elements instead.");
1297 return SCM_I_VECTOR_ELTS (x
);
1301 scm_i_writable_velts (SCM x
)
1303 scm_c_issue_deprecation_warning
1304 ("SCM_WRITABLE_VELTS is deprecated. "
1305 "Use scm_vector_writable_elements instead.");
1306 return SCM_I_VECTOR_WELTS (x
);
1310 scm_i_vector_ref (SCM x
, size_t idx
)
1312 scm_c_issue_deprecation_warning
1313 ("SCM_VECTOR_REF is deprecated. "
1314 "Use scm_c_vector_ref or scm_vector_elements instead.");
1315 return scm_c_vector_ref (x
, idx
);
1319 scm_i_vector_set (SCM x
, size_t idx
, SCM val
)
1321 scm_c_issue_deprecation_warning
1322 ("SCM_VECTOR_SET is deprecated. "
1323 "Use scm_c_vector_set_x or scm_vector_writable_elements instead.");
1324 scm_c_vector_set_x (x
, idx
, val
);
1328 scm_vector_equal_p (SCM x
, SCM y
)
1330 scm_c_issue_deprecation_warning
1331 ("scm_vector_euqal_p is deprecated. "
1332 "Use scm_equal_p instead.");
1333 return scm_equal_p (x
, y
);
1336 SCM_DEFINE (scm_uniform_vector_read_x
, "uniform-vector-read!", 1, 3, 0,
1337 (SCM uvec
, SCM port_or_fd
, SCM start
, SCM end
),
1338 "Fill the elements of @var{uvec} by reading\n"
1339 "raw bytes from @var{port-or-fdes}, using host byte order.\n\n"
1340 "The optional arguments @var{start} (inclusive) and @var{end}\n"
1341 "(exclusive) allow a specified region to be read,\n"
1342 "leaving the remainder of the vector unchanged.\n\n"
1343 "When @var{port-or-fdes} is a port, all specified elements\n"
1344 "of @var{uvec} are attempted to be read, potentially blocking\n"
1345 "while waiting for more input or end-of-file.\n"
1346 "When @var{port-or-fd} is an integer, a single call to\n"
1347 "read(2) is made.\n\n"
1348 "An error is signalled when the last element has only\n"
1349 "been partially filled before reaching end-of-file or in\n"
1350 "the single call to read(2).\n\n"
1351 "@code{uniform-vector-read!} returns the number of elements\n"
1353 "@var{port-or-fdes} may be omitted, in which case it defaults\n"
1354 "to the value returned by @code{(current-input-port)}.")
1355 #define FUNC_NAME s_scm_uniform_vector_read_x
1358 size_t c_width
, c_start
, c_end
;
1360 SCM_VALIDATE_BYTEVECTOR (SCM_ARG1
, uvec
);
1362 scm_c_issue_deprecation_warning
1363 ("`uniform-vector-read!' is deprecated. Use `get-bytevector-n!' from\n"
1364 "`(rnrs io ports)' instead.");
1366 if (SCM_UNBNDP (port_or_fd
))
1367 port_or_fd
= scm_current_input_port ();
1369 c_width
= scm_to_size_t (scm_uniform_vector_element_size (uvec
));
1371 c_start
= SCM_UNBNDP (start
) ? 0 : scm_to_size_t (start
);
1374 c_end
= SCM_UNBNDP (end
) ? SCM_BYTEVECTOR_LENGTH (uvec
) : scm_to_size_t (end
);
1377 result
= scm_get_bytevector_n_x (port_or_fd
, uvec
,
1378 scm_from_size_t (c_start
),
1379 scm_from_size_t (c_end
- c_start
));
1381 if (SCM_EOF_OBJECT_P (result
))
1388 SCM_DEFINE (scm_uniform_vector_write
, "uniform-vector-write", 1, 3, 0,
1389 (SCM uvec
, SCM port_or_fd
, SCM start
, SCM end
),
1390 "Write the elements of @var{uvec} as raw bytes to\n"
1391 "@var{port-or-fdes}, in the host byte order.\n\n"
1392 "The optional arguments @var{start} (inclusive)\n"
1393 "and @var{end} (exclusive) allow\n"
1394 "a specified region to be written.\n\n"
1395 "When @var{port-or-fdes} is a port, all specified elements\n"
1396 "of @var{uvec} are attempted to be written, potentially blocking\n"
1397 "while waiting for more room.\n"
1398 "When @var{port-or-fd} is an integer, a single call to\n"
1399 "write(2) is made.\n\n"
1400 "An error is signalled when the last element has only\n"
1401 "been partially written in the single call to write(2).\n\n"
1402 "The number of objects actually written is returned.\n"
1403 "@var{port-or-fdes} may be\n"
1404 "omitted, in which case it defaults to the value returned by\n"
1405 "@code{(current-output-port)}.")
1406 #define FUNC_NAME s_scm_uniform_vector_write
1408 size_t c_width
, c_start
, c_end
;
1410 SCM_VALIDATE_BYTEVECTOR (SCM_ARG1
, uvec
);
1412 scm_c_issue_deprecation_warning
1413 ("`uniform-vector-write' is deprecated. Use `put-bytevector' from\n"
1414 "`(rnrs io ports)' instead.");
1416 if (SCM_UNBNDP (port_or_fd
))
1417 port_or_fd
= scm_current_output_port ();
1419 port_or_fd
= SCM_COERCE_OUTPORT (port_or_fd
);
1421 c_width
= scm_to_size_t (scm_uniform_vector_element_size (uvec
));
1423 c_start
= SCM_UNBNDP (start
) ? 0 : scm_to_size_t (start
);
1426 c_end
= SCM_UNBNDP (end
) ? SCM_BYTEVECTOR_LENGTH (uvec
) : scm_to_size_t (end
);
1429 return scm_put_bytevector (port_or_fd
, uvec
,
1430 scm_from_size_t (c_start
),
1431 scm_from_size_t (c_end
- c_start
));
1436 scm_ra2contig (SCM ra
, int copy
)
1441 for (k
= SCM_I_ARRAY_NDIM (ra
); k
--;)
1442 len
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1443 k
= SCM_I_ARRAY_NDIM (ra
);
1444 if (SCM_I_ARRAY_CONTP (ra
) && ((0 == k
) || (1 == SCM_I_ARRAY_DIMS (ra
)[k
- 1].inc
)))
1446 if (!scm_is_bitvector (SCM_I_ARRAY_V (ra
)))
1448 if ((len
== scm_c_bitvector_length (SCM_I_ARRAY_V (ra
)) &&
1449 0 == SCM_I_ARRAY_BASE (ra
) % SCM_LONG_BIT
&&
1450 0 == len
% SCM_LONG_BIT
))
1453 ret
= scm_i_make_array (k
);
1454 SCM_I_ARRAY_BASE (ret
) = 0;
1457 SCM_I_ARRAY_DIMS (ret
)[k
].lbnd
= SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
;
1458 SCM_I_ARRAY_DIMS (ret
)[k
].ubnd
= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
;
1459 SCM_I_ARRAY_DIMS (ret
)[k
].inc
= inc
;
1460 inc
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1462 SCM_I_ARRAY_V (ret
) =
1463 scm_make_generalized_vector (scm_array_type (ra
), scm_from_size_t (inc
),
1466 scm_array_copy_x (ra
, ret
);
1470 SCM_DEFINE (scm_uniform_array_read_x
, "uniform-array-read!", 1, 3, 0,
1471 (SCM ura
, SCM port_or_fd
, SCM start
, SCM end
),
1472 "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
1473 "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
1474 "binary objects from @var{port-or-fdes}.\n"
1475 "If an end of file is encountered,\n"
1476 "the objects up to that point are put into @var{ura}\n"
1477 "(starting at the beginning) and the remainder of the array is\n"
1479 "The optional arguments @var{start} and @var{end} allow\n"
1480 "a specified region of a vector (or linearized array) to be read,\n"
1481 "leaving the remainder of the vector unchanged.\n\n"
1482 "@code{uniform-array-read!} returns the number of objects read.\n"
1483 "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
1484 "returned by @code{(current-input-port)}.")
1485 #define FUNC_NAME s_scm_uniform_array_read_x
1487 if (SCM_UNBNDP (port_or_fd
))
1488 port_or_fd
= scm_current_input_port ();
1490 if (scm_is_uniform_vector (ura
))
1492 return scm_uniform_vector_read_x (ura
, port_or_fd
, start
, end
);
1494 else if (SCM_I_ARRAYP (ura
))
1496 size_t base
, vlen
, cstart
, cend
;
1499 cra
= scm_ra2contig (ura
, 0);
1500 base
= SCM_I_ARRAY_BASE (cra
);
1501 vlen
= SCM_I_ARRAY_DIMS (cra
)->inc
*
1502 (SCM_I_ARRAY_DIMS (cra
)->ubnd
- SCM_I_ARRAY_DIMS (cra
)->lbnd
+ 1);
1506 if (!SCM_UNBNDP (start
))
1508 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
1509 if (!SCM_UNBNDP (end
))
1510 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
1513 ans
= scm_uniform_vector_read_x (SCM_I_ARRAY_V (cra
), port_or_fd
,
1514 scm_from_size_t (base
+ cstart
),
1515 scm_from_size_t (base
+ cend
));
1517 if (!scm_is_eq (cra
, ura
))
1518 scm_array_copy_x (cra
, ura
);
1522 scm_wrong_type_arg_msg (NULL
, 0, ura
, "array");
1526 SCM_DEFINE (scm_uniform_array_write
, "uniform-array-write", 1, 3, 0,
1527 (SCM ura
, SCM port_or_fd
, SCM start
, SCM end
),
1528 "Writes all elements of @var{ura} as binary objects to\n"
1529 "@var{port-or-fdes}.\n\n"
1530 "The optional arguments @var{start}\n"
1531 "and @var{end} allow\n"
1532 "a specified region of a vector (or linearized array) to be written.\n\n"
1533 "The number of objects actually written is returned.\n"
1534 "@var{port-or-fdes} may be\n"
1535 "omitted, in which case it defaults to the value returned by\n"
1536 "@code{(current-output-port)}.")
1537 #define FUNC_NAME s_scm_uniform_array_write
1539 if (SCM_UNBNDP (port_or_fd
))
1540 port_or_fd
= scm_current_output_port ();
1542 if (scm_is_uniform_vector (ura
))
1544 return scm_uniform_vector_write (ura
, port_or_fd
, start
, end
);
1546 else if (SCM_I_ARRAYP (ura
))
1548 size_t base
, vlen
, cstart
, cend
;
1551 cra
= scm_ra2contig (ura
, 1);
1552 base
= SCM_I_ARRAY_BASE (cra
);
1553 vlen
= SCM_I_ARRAY_DIMS (cra
)->inc
*
1554 (SCM_I_ARRAY_DIMS (cra
)->ubnd
- SCM_I_ARRAY_DIMS (cra
)->lbnd
+ 1);
1558 if (!SCM_UNBNDP (start
))
1560 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
1561 if (!SCM_UNBNDP (end
))
1562 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
1565 ans
= scm_uniform_vector_write (SCM_I_ARRAY_V (cra
), port_or_fd
,
1566 scm_from_size_t (base
+ cstart
),
1567 scm_from_size_t (base
+ cend
));
1572 scm_wrong_type_arg_msg (NULL
, 0, ura
, "array");
1577 scm_i_cur_inp (void)
1579 scm_c_issue_deprecation_warning
1580 ("scm_cur_inp is deprecated. Use scm_current_input_port instead.");
1581 return scm_current_input_port ();
1585 scm_i_cur_outp (void)
1587 scm_c_issue_deprecation_warning
1588 ("scm_cur_outp is deprecated. Use scm_current_output_port instead.");
1589 return scm_current_output_port ();
1593 scm_i_cur_errp (void)
1595 scm_c_issue_deprecation_warning
1596 ("scm_cur_errp is deprecated. Use scm_current_error_port instead.");
1597 return scm_current_error_port ();
1601 scm_i_cur_loadp (void)
1603 scm_c_issue_deprecation_warning
1604 ("scm_cur_loadp is deprecated. Use scm_current_load_port instead.");
1605 return scm_current_load_port ();
1609 scm_i_progargs (void)
1611 scm_c_issue_deprecation_warning
1612 ("scm_progargs is deprecated. Use scm_program_arguments instead.");
1613 return scm_program_arguments ();
1617 scm_i_deprecated_dynwinds (void)
1619 scm_c_issue_deprecation_warning
1620 ("scm_dynwinds is deprecated. Do not use it.");
1621 return scm_i_dynwinds ();
1625 scm_i_stack_base (void)
1627 scm_c_issue_deprecation_warning
1628 ("scm_stack_base is deprecated. Do not use it.");
1629 return SCM_I_CURRENT_THREAD
->base
;
1633 scm_i_fluidp (SCM x
)
1635 scm_c_issue_deprecation_warning
1636 ("SCM_FLUIDP is deprecated. Use scm_is_fluid instead.");
1637 return scm_is_fluid (x
);
1643 #ifdef HAVE_NETWORKING
1645 SCM_DEFINE (scm_inet_aton
, "inet-aton", 1, 0, 0,
1647 "Convert an IPv4 Internet address from printable string\n"
1648 "(dotted decimal notation) to an integer. E.g.,\n\n"
1650 "(inet-aton \"127.0.0.1\") @result{} 2130706433\n"
1652 #define FUNC_NAME s_scm_inet_aton
1654 scm_c_issue_deprecation_warning
1655 ("`inet-aton' is deprecated. Use `inet-pton' instead.");
1657 return scm_inet_pton (scm_from_int (AF_INET
), address
);
1662 SCM_DEFINE (scm_inet_ntoa
, "inet-ntoa", 1, 0, 0,
1664 "Convert an IPv4 Internet address to a printable\n"
1665 "(dotted decimal notation) string. E.g.,\n\n"
1667 "(inet-ntoa 2130706433) @result{} \"127.0.0.1\"\n"
1669 #define FUNC_NAME s_scm_inet_ntoa
1671 scm_c_issue_deprecation_warning
1672 ("`inet-ntoa' is deprecated. Use `inet-ntop' instead.");
1674 return scm_inet_ntop (scm_from_int (AF_INET
), inetid
);
1678 #endif /* HAVE_NETWORKING */
1682 scm_i_defer_ints_etc ()
1684 scm_c_issue_deprecation_warning
1685 ("SCM_DEFER_INTS etc are deprecated. "
1686 "Use a mutex instead if appropriate.");
1690 scm_i_mask_ints (void)
1692 scm_c_issue_deprecation_warning ("`scm_mask_ints' is deprecated.");
1693 return (SCM_I_CURRENT_THREAD
->block_asyncs
!= 0);
1698 scm_guard (SCM guardian
, SCM obj
, int throw_p
)
1700 scm_c_issue_deprecation_warning
1701 ("scm_guard is deprecated. Use scm_call_1 instead.");
1703 return scm_call_1 (guardian
, obj
);
1707 scm_get_one_zombie (SCM guardian
)
1709 scm_c_issue_deprecation_warning
1710 ("scm_guard is deprecated. Use scm_call_0 instead.");
1712 return scm_call_0 (guardian
);
1715 SCM_DEFINE (scm_guardian_destroyed_p
, "guardian-destroyed?", 1, 0, 0,
1717 "Return @code{#t} if @var{guardian} has been destroyed, otherwise @code{#f}.")
1718 #define FUNC_NAME s_scm_guardian_destroyed_p
1720 scm_c_issue_deprecation_warning
1721 ("'guardian-destroyed?' is deprecated.");
1726 SCM_DEFINE (scm_guardian_greedy_p
, "guardian-greedy?", 1, 0, 0,
1728 "Return @code{#t} if @var{guardian} is a greedy guardian, otherwise @code{#f}.")
1729 #define FUNC_NAME s_scm_guardian_greedy_p
1731 scm_c_issue_deprecation_warning
1732 ("'guardian-greedy?' is deprecated.");
1737 SCM_DEFINE (scm_destroy_guardian_x
, "destroy-guardian!", 1, 0, 0,
1739 "Destroys @var{guardian}, by making it impossible to put any more\n"
1740 "objects in it or get any objects from it. It also unguards any\n"
1741 "objects guarded by @var{guardian}.")
1742 #define FUNC_NAME s_scm_destroy_guardian_x
1744 scm_c_issue_deprecation_warning
1745 ("'destroy-guardian!' is deprecated and ineffective.");
1746 return SCM_UNSPECIFIED
;
1751 /* GC-related things. */
1753 unsigned long scm_mallocated
, scm_mtrigger
;
1754 size_t scm_max_segment_size
;
1756 #if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST)
1758 scm_map_free_list (void)
1764 #if defined (GUILE_DEBUG_FREELIST)
1766 scm_gc_set_debug_check_freelist_x (SCM flag
)
1768 return SCM_UNSPECIFIED
;
1775 * Trampolines were an intent to speed up calling the same Scheme procedure many
1778 * However, this was the wrong thing to optimize; if you really know what you're
1779 * calling, call its function directly, otherwise you're in Scheme-land, and we
1780 * have many better tricks there (inlining, for example, which can remove the
1781 * need for closures and free variables).
1783 * Also, in the normal debugging case, trampolines were being computed but not
1788 scm_trampoline_0 (SCM proc
)
1790 scm_c_issue_deprecation_warning
1791 ("`scm_trampoline_0' is deprecated. Just use `scm_call_0' instead.");
1796 scm_trampoline_1 (SCM proc
)
1798 scm_c_issue_deprecation_warning
1799 ("`scm_trampoline_1' is deprecated. Just use `scm_call_1' instead.");
1804 scm_trampoline_2 (SCM proc
)
1806 scm_c_issue_deprecation_warning
1807 ("`scm_trampoline_2' is deprecated. Just use `scm_call_2' instead.");
1812 scm_i_subr_p (SCM x
)
1814 scm_c_issue_deprecation_warning ("`scm_subr_p' is deprecated. Use SCM_PRIMITIVE_P instead.");
1815 return SCM_PRIMITIVE_P (x
);
1821 scm_internal_lazy_catch (SCM tag
, scm_t_catch_body body
, void *body_data
, scm_t_catch_handler handler
, void *handler_data
)
1823 scm_c_issue_deprecation_warning
1824 ("`scm_internal_lazy_catch' is no longer supported. Instead this call will\n"
1825 "dispatch to `scm_c_with_throw_handler'. Your handler will be invoked from\n"
1826 "within the dynamic context of the corresponding `throw'.\n"
1827 "\nTHIS COULD CHANGE YOUR PROGRAM'S BEHAVIOR.\n\n"
1828 "Please modify your program to use `scm_c_with_throw_handler' directly,\n"
1829 "and adapt it (if necessary) to expect to be within the dynamic context\n"
1831 return scm_c_with_throw_handler (tag
, body
, body_data
, handler
, handler_data
, 0);
1834 SCM_DEFINE (scm_lazy_catch
, "lazy-catch", 3, 0, 0,
1835 (SCM key
, SCM thunk
, SCM handler
),
1836 "This behaves exactly like @code{catch}, except that it does\n"
1837 "not unwind the stack before invoking @var{handler}.\n"
1838 "If the @var{handler} procedure returns normally, Guile\n"
1839 "rethrows the same exception again to the next innermost catch,\n"
1840 "lazy-catch or throw handler. If the @var{handler} exits\n"
1841 "non-locally, that exit determines the continuation.")
1842 #define FUNC_NAME s_scm_lazy_catch
1844 struct scm_body_thunk_data c
;
1846 SCM_ASSERT (scm_is_symbol (key
) || scm_is_eq (key
, SCM_BOOL_T
),
1847 key
, SCM_ARG1
, FUNC_NAME
);
1850 c
.body_proc
= thunk
;
1852 scm_c_issue_deprecation_warning
1853 ("`lazy-catch' is no longer supported. Instead this call will dispatch\n"
1854 "to `with-throw-handler'. Your handler will be invoked from within the\n"
1855 "dynamic context of the corresponding `throw'.\n"
1856 "\nTHIS COULD CHANGE YOUR PROGRAM'S BEHAVIOR.\n\n"
1857 "Please modify your program to use `with-throw-handler' directly, and\n"
1858 "adapt it (if necessary) to expect to be within the dynamic context of\n"
1861 return scm_c_with_throw_handler (key
,
1863 scm_handle_by_proc
, &handler
, 0);
1872 scm_raequal (SCM ra0
, SCM ra1
)
1874 return scm_array_equal_p (ra0
, ra1
);
1881 SCM_DEFINE (scm_dynamic_args_call
, "dynamic-args-call", 3, 0, 0,
1882 (SCM func
, SCM dobj
, SCM args
),
1883 "Call the C function indicated by @var{func} and @var{dobj},\n"
1884 "just like @code{dynamic-call}, but pass it some arguments and\n"
1885 "return its return value. The C function is expected to take\n"
1886 "two arguments and return an @code{int}, just like @code{main}:\n"
1888 "int c_func (int argc, char **argv);\n"
1889 "@end smallexample\n\n"
1890 "The parameter @var{args} must be a list of strings and is\n"
1891 "converted into an array of @code{char *}. The array is passed\n"
1892 "in @var{argv} and its size in @var{argc}. The return value is\n"
1893 "converted to a Scheme number and returned from the call to\n"
1894 "@code{dynamic-args-call}.")
1895 #define FUNC_NAME s_scm_dynamic_args_call
1897 int (*fptr
) (int argc
, char **argv
);
1901 if (scm_is_string (func
))
1904 func
= scm_dynamic_func (func
, dobj
);
1906 scm_misc_error ("dynamic-args-call",
1907 "dynamic-func not available to resolve ~S",
1911 SCM_VALIDATE_POINTER (SCM_ARG1
, func
);
1913 fptr
= SCM_POINTER_VALUE (func
);
1915 argv
= scm_i_allocate_string_pointers (args
);
1916 for (argc
= 0; argv
[argc
]; argc
++)
1918 result
= (*fptr
) (argc
, argv
);
1920 return scm_from_int (result
);
1929 scm_badargsp (SCM formals
, SCM args
)
1931 scm_c_issue_deprecation_warning
1932 ("`scm_badargsp' is deprecated. Copy it into your project if you need it.");
1934 while (!scm_is_null (formals
))
1936 if (!scm_is_pair (formals
))
1938 if (scm_is_null (args
))
1940 formals
= scm_cdr (formals
);
1941 args
= scm_cdr (args
);
1943 return !scm_is_null (args
) ? 1 : 0;
1948 /* scm_internal_stack_catch
1949 Use this one if you want debugging information to be stored in
1950 the-last-stack on error. */
1953 ss_handler (void *data SCM_UNUSED
, SCM tag
, SCM throw_args
)
1956 scm_fluid_set_x (scm_variable_ref
1957 (scm_c_module_lookup
1958 (scm_c_resolve_module ("ice-9 save-stack"),
1960 scm_make_stack (SCM_BOOL_T
, SCM_EOL
));
1961 /* Throw the error */
1962 return scm_throw (tag
, throw_args
);
1968 scm_t_catch_body body
;
1973 cwss_body (void *data
)
1975 struct cwss_data
*d
= data
;
1976 return scm_c_with_throw_handler (d
->tag
, d
->body
, d
->data
, ss_handler
, NULL
, 0);
1980 scm_internal_stack_catch (SCM tag
,
1981 scm_t_catch_body body
,
1983 scm_t_catch_handler handler
,
1990 scm_c_issue_deprecation_warning
1991 ("`scm_internal_stack_catch' is deprecated. Talk to guile-devel if you see this message.");
1992 return scm_internal_catch (tag
, cwss_body
, &d
, handler
, handler_data
);
1998 scm_short2num (short x
)
2000 scm_c_issue_deprecation_warning
2001 ("`scm_short2num' is deprecated. Use scm_from_short instead.");
2002 return scm_from_short (x
);
2006 scm_ushort2num (unsigned short x
)
2008 scm_c_issue_deprecation_warning
2009 ("`scm_ushort2num' is deprecated. Use scm_from_ushort instead.");
2010 return scm_from_ushort (x
);
2016 scm_c_issue_deprecation_warning
2017 ("`scm_int2num' is deprecated. Use scm_from_int instead.");
2018 return scm_from_int (x
);
2022 scm_uint2num (unsigned int x
)
2024 scm_c_issue_deprecation_warning
2025 ("`scm_uint2num' is deprecated. Use scm_from_uint instead.");
2026 return scm_from_uint (x
);
2030 scm_long2num (long x
)
2032 scm_c_issue_deprecation_warning
2033 ("`scm_long2num' is deprecated. Use scm_from_long instead.");
2034 return scm_from_long (x
);
2038 scm_ulong2num (unsigned long x
)
2040 scm_c_issue_deprecation_warning
2041 ("`scm_ulong2num' is deprecated. Use scm_from_ulong instead.");
2042 return scm_from_ulong (x
);
2046 scm_size2num (size_t x
)
2048 scm_c_issue_deprecation_warning
2049 ("`scm_size2num' is deprecated. Use scm_from_size_t instead.");
2050 return scm_from_size_t (x
);
2054 scm_ptrdiff2num (ptrdiff_t x
)
2056 scm_c_issue_deprecation_warning
2057 ("`scm_ptrdiff2num' is deprecated. Use scm_from_ssize_t instead.");
2058 return scm_from_ssize_t (x
);
2062 scm_num2short (SCM x
, unsigned long pos
, const char *s_caller
)
2064 scm_c_issue_deprecation_warning
2065 ("`scm_num2short' is deprecated. Use scm_to_short instead.");
2066 return scm_to_short (x
);
2070 scm_num2ushort (SCM x
, unsigned long pos
, const char *s_caller
)
2072 scm_c_issue_deprecation_warning
2073 ("`scm_num2ushort' is deprecated. Use scm_to_ushort instead.");
2074 return scm_to_ushort (x
);
2078 scm_num2int (SCM x
, unsigned long pos
, const char *s_caller
)
2080 scm_c_issue_deprecation_warning
2081 ("`scm_num2int' is deprecated. Use scm_to_int instead.");
2082 return scm_to_int (x
);
2086 scm_num2uint (SCM x
, unsigned long pos
, const char *s_caller
)
2088 scm_c_issue_deprecation_warning
2089 ("`scm_num2uint' is deprecated. Use scm_to_uint instead.");
2090 return scm_to_uint (x
);
2094 scm_num2long (SCM x
, unsigned long pos
, const char *s_caller
)
2096 scm_c_issue_deprecation_warning
2097 ("`scm_num2long' is deprecated. Use scm_to_long instead.");
2098 return scm_to_long (x
);
2102 scm_num2ulong (SCM x
, unsigned long pos
, const char *s_caller
)
2104 scm_c_issue_deprecation_warning
2105 ("`scm_num2ulong' is deprecated. Use scm_to_ulong instead.");
2106 return scm_to_ulong (x
);
2110 scm_num2size (SCM x
, unsigned long pos
, const char *s_caller
)
2112 scm_c_issue_deprecation_warning
2113 ("`scm_num2size' is deprecated. Use scm_to_size_t instead.");
2114 return scm_to_size_t (x
);
2118 scm_num2ptrdiff (SCM x
, unsigned long pos
, const char *s_caller
)
2120 scm_c_issue_deprecation_warning
2121 ("`scm_num2ptrdiff' is deprecated. Use scm_to_ssize_t instead.");
2122 return scm_to_ssize_t (x
);
2125 #if SCM_SIZEOF_LONG_LONG != 0
2128 scm_long_long2num (long long x
)
2130 scm_c_issue_deprecation_warning
2131 ("`scm_long_long2num' is deprecated. Use scm_from_long_long instead.");
2132 return scm_from_long_long (x
);
2136 scm_ulong_long2num (unsigned long long x
)
2138 scm_c_issue_deprecation_warning
2139 ("`scm_ulong_long2num' is deprecated. Use scm_from_ulong_long instead.");
2140 return scm_from_ulong_long (x
);
2144 scm_num2long_long (SCM x
, unsigned long pos
, const char *s_caller
)
2146 scm_c_issue_deprecation_warning
2147 ("`scm_num2long_long' is deprecated. Use scm_to_long_long instead.");
2148 return scm_to_long_long (x
);
2152 scm_num2ulong_long (SCM x
, unsigned long pos
, const char *s_caller
)
2154 scm_c_issue_deprecation_warning
2155 ("`scm_num2ulong_long' is deprecated. Use scm_from_ulong_long instead.");
2156 return scm_to_ulong_long (x
);
2162 scm_make_real (double x
)
2164 scm_c_issue_deprecation_warning
2165 ("`scm_make_real' is deprecated. Use scm_from_double instead.");
2166 return scm_from_double (x
);
2170 scm_num2dbl (SCM a
, const char *why
)
2172 scm_c_issue_deprecation_warning
2173 ("`scm_num2dbl' is deprecated. Use scm_to_double instead.");
2174 return scm_to_double (a
);
2178 scm_float2num (float n
)
2180 scm_c_issue_deprecation_warning
2181 ("`scm_float2num' is deprecated. Use scm_from_double instead.");
2182 return scm_from_double ((double) n
);
2186 scm_double2num (double n
)
2188 scm_c_issue_deprecation_warning
2189 ("`scm_double2num' is deprecated. Use scm_from_double instead.");
2190 return scm_from_double (n
);
2194 scm_make_complex (double x
, double y
)
2196 scm_c_issue_deprecation_warning
2197 ("`scm_make_complex' is deprecated. Use scm_c_make_rectangular instead.");
2198 return scm_c_make_rectangular (x
, y
);
2202 scm_mem2symbol (const char *mem
, size_t len
)
2204 scm_c_issue_deprecation_warning
2205 ("`scm_mem2symbol' is deprecated. Use scm_from_locale_symboln instead.");
2206 return scm_from_locale_symboln (mem
, len
);
2210 scm_mem2uninterned_symbol (const char *mem
, size_t len
)
2212 scm_c_issue_deprecation_warning
2213 ("`scm_mem2uninterned_symbol' is deprecated. "
2214 "Use scm_make_symbol and scm_from_locale_symboln instead.");
2215 return scm_make_symbol (scm_from_locale_stringn (mem
, len
));
2219 scm_str2symbol (const char *str
)
2221 scm_c_issue_deprecation_warning
2222 ("`scm_str2symbol' is deprecated. Use scm_from_locale_symbol instead.");
2223 return scm_from_locale_symbol (str
);
2227 /* This function must only be applied to memory obtained via malloc,
2228 since the GC is going to apply `free' to it when the string is
2231 Also, s[len] must be `\0', since we promise that strings are
2232 null-terminated. Perhaps we could handle non-null-terminated
2233 strings by claiming they're shared substrings of a string we just
2236 scm_take_str (char *s
, size_t len
)
2238 scm_c_issue_deprecation_warning
2239 ("`scm_take_str' is deprecated. Use scm_take_locale_stringn instead.");
2240 return scm_take_locale_stringn (s
, len
);
2243 /* `s' must be a malloc'd string. See scm_take_str. */
2245 scm_take0str (char *s
)
2247 scm_c_issue_deprecation_warning
2248 ("`scm_take0str' is deprecated. Use scm_take_locale_string instead.");
2249 return scm_take_locale_string (s
);
2253 scm_mem2string (const char *src
, size_t len
)
2255 scm_c_issue_deprecation_warning
2256 ("`scm_mem2string' is deprecated. Use scm_from_locale_stringn instead.");
2257 return scm_from_locale_stringn (src
, len
);
2261 scm_str2string (const char *src
)
2263 scm_c_issue_deprecation_warning
2264 ("`scm_str2string' is deprecated. Use scm_from_locale_string instead.");
2265 return scm_from_locale_string (src
);
2269 scm_makfrom0str (const char *src
)
2271 scm_c_issue_deprecation_warning
2272 ("`scm_makfrom0str' is deprecated."
2273 "Use scm_from_locale_string instead, but check for NULL first.");
2274 if (!src
) return SCM_BOOL_F
;
2275 return scm_from_locale_string (src
);
2279 scm_makfrom0str_opt (const char *src
)
2281 scm_c_issue_deprecation_warning
2282 ("`scm_makfrom0str_opt' is deprecated."
2283 "Use scm_from_locale_string instead, but check for NULL first.");
2284 return scm_makfrom0str (src
);
2289 scm_allocate_string (size_t len
)
2291 scm_c_issue_deprecation_warning
2292 ("`scm_allocate_string' is deprecated. Use scm_c_make_string instead.");
2293 return scm_i_make_string (len
, NULL
, 0);
2296 SCM_DEFINE (scm_make_keyword_from_dash_symbol
, "make-keyword-from-dash-symbol", 1, 0, 0,
2298 "Make a keyword object from a @var{symbol} that starts with a dash.")
2299 #define FUNC_NAME s_scm_make_keyword_from_dash_symbol
2301 SCM dash_string
, non_dash_symbol
;
2303 scm_c_issue_deprecation_warning
2304 ("`scm_make_keyword_from_dash_symbol' is deprecated. Don't use dash symbols.");
2306 SCM_ASSERT (scm_is_symbol (symbol
)
2307 && (scm_i_symbol_ref (symbol
, 0) == '-'),
2308 symbol
, SCM_ARG1
, FUNC_NAME
);
2310 dash_string
= scm_symbol_to_string (symbol
);
2312 scm_string_to_symbol (scm_c_substring (dash_string
,
2314 scm_c_string_length (dash_string
)));
2316 return scm_symbol_to_keyword (non_dash_symbol
);
2320 SCM_DEFINE (scm_keyword_dash_symbol
, "keyword-dash-symbol", 1, 0, 0,
2322 "Return the dash symbol for @var{keyword}.\n"
2323 "This is the inverse of @code{make-keyword-from-dash-symbol}.")
2324 #define FUNC_NAME s_scm_keyword_dash_symbol
2326 SCM symbol
= scm_keyword_to_symbol (keyword
);
2327 SCM parts
= scm_list_2 (scm_from_locale_string ("-"),
2328 scm_symbol_to_string (symbol
));
2329 scm_c_issue_deprecation_warning
2330 ("`scm_keyword_dash_symbol' is deprecated. Don't use dash symbols.");
2332 return scm_string_to_symbol (scm_string_append (parts
));
2337 scm_c_make_keyword (const char *s
)
2339 scm_c_issue_deprecation_warning
2340 ("`scm_c_make_keyword' is deprecated. Use scm_from_locale_keyword instead.");
2341 return scm_from_locale_keyword (s
);
2345 scm_thread_sleep (unsigned int t
)
2347 scm_c_issue_deprecation_warning
2348 ("`scm_thread_sleep' is deprecated. Use scm_std_sleep instead.");
2349 return scm_std_sleep (t
);
2353 scm_thread_usleep (unsigned long t
)
2355 scm_c_issue_deprecation_warning
2356 ("`scm_thread_usleep' is deprecated. Use scm_std_usleep instead.");
2357 return scm_std_usleep (t
);
2360 #ifdef HAVE_SYS_SELECT_H
2361 int scm_internal_select (int fds
,
2365 struct timeval
*timeout
)
2367 scm_c_issue_deprecation_warning
2368 ("`scm_internal_select' is deprecated. Use scm_std_select instead.");
2369 return scm_std_select (fds
, rfds
, wfds
, efds
, timeout
);
2371 #endif /* HAVE_SYS_SELECT_H */
2377 # if !HAVE_DECL_CUSERID
2378 extern char *cuserid (char *);
2381 SCM_DEFINE (scm_cuserid
, "cuserid", 0, 0, 0,
2383 "Return a string containing a user name associated with the\n"
2384 "effective user id of the process. Return @code{#f} if this\n"
2385 "information cannot be obtained.")
2386 #define FUNC_NAME s_scm_cuserid
2388 char buf
[L_cuserid
];
2391 scm_c_issue_deprecation_warning
2392 ("`cuserid' is deprecated. Use `(passwd:name (getpwuid (geteuid)))' instead.");
2397 return scm_from_locale_string (p
);
2400 #endif /* HAVE_CUSERID */
2407 static SCM properties_whash
;
2409 SCM_DEFINE (scm_primitive_make_property
, "primitive-make-property", 1, 0, 0,
2410 (SCM not_found_proc
),
2411 "Create a @dfn{property token} that can be used with\n"
2412 "@code{primitive-property-ref} and @code{primitive-property-set!}.\n"
2413 "See @code{primitive-property-ref} for the significance of\n"
2414 "@var{not_found_proc}.")
2415 #define FUNC_NAME s_scm_primitive_make_property
2417 scm_c_issue_deprecation_warning
2418 ("`primitive-make-property' is deprecated. Use object properties.");
2420 if (!scm_is_false (not_found_proc
))
2421 SCM_VALIDATE_PROC (SCM_ARG1
, not_found_proc
);
2422 return scm_cons (not_found_proc
, SCM_EOL
);
2427 SCM_DEFINE (scm_primitive_property_ref
, "primitive-property-ref", 2, 0, 0,
2428 (SCM prop
, SCM obj
),
2429 "Return the property @var{prop} of @var{obj}.\n"
2431 "When no value has yet been associated with @var{prop} and\n"
2432 "@var{obj}, the @var{not-found-proc} from @var{prop} is used. A\n"
2433 "call @code{(@var{not-found-proc} @var{prop} @var{obj})} is made\n"
2434 "and the result set as the property value. If\n"
2435 "@var{not-found-proc} is @code{#f} then @code{#f} is the\n"
2437 #define FUNC_NAME s_scm_primitive_property_ref
2441 scm_c_issue_deprecation_warning
2442 ("`primitive-property-ref' is deprecated. Use object properties.");
2444 SCM_VALIDATE_CONS (SCM_ARG1
, prop
);
2446 alist
= scm_hashq_ref (properties_whash
, obj
, SCM_EOL
);
2447 if (scm_is_pair (alist
))
2449 SCM assoc
= scm_assq (prop
, alist
);
2450 if (scm_is_true (assoc
))
2451 return SCM_CDR (assoc
);
2454 if (scm_is_false (SCM_CAR (prop
)))
2458 SCM val
= scm_call_2 (SCM_CAR (prop
), prop
, obj
);
2459 scm_hashq_set_x (properties_whash
, obj
,
2460 scm_acons (prop
, val
, alist
));
2467 SCM_DEFINE (scm_primitive_property_set_x
, "primitive-property-set!", 3, 0, 0,
2468 (SCM prop
, SCM obj
, SCM val
),
2469 "Set the property @var{prop} of @var{obj} to @var{val}.")
2470 #define FUNC_NAME s_scm_primitive_property_set_x
2474 scm_c_issue_deprecation_warning
2475 ("`primitive-property-set!' is deprecated. Use object properties.");
2477 SCM_VALIDATE_CONS (SCM_ARG1
, prop
);
2478 alist
= scm_hashq_ref (properties_whash
, obj
, SCM_EOL
);
2479 assoc
= scm_assq (prop
, alist
);
2480 if (scm_is_pair (assoc
))
2481 SCM_SETCDR (assoc
, val
);
2483 scm_hashq_set_x (properties_whash
, obj
,
2484 scm_acons (prop
, val
, alist
));
2485 return SCM_UNSPECIFIED
;
2490 SCM_DEFINE (scm_primitive_property_del_x
, "primitive-property-del!", 2, 0, 0,
2491 (SCM prop
, SCM obj
),
2492 "Remove any value associated with @var{prop} and @var{obj}.")
2493 #define FUNC_NAME s_scm_primitive_property_del_x
2497 scm_c_issue_deprecation_warning
2498 ("`primitive-property-del!' is deprecated. Use object properties.");
2500 SCM_VALIDATE_CONS (SCM_ARG1
, prop
);
2501 alist
= scm_hashq_ref (properties_whash
, obj
, SCM_EOL
);
2502 if (scm_is_pair (alist
))
2503 scm_hashq_set_x (properties_whash
, obj
, scm_assq_remove_x (alist
, prop
));
2504 return SCM_UNSPECIFIED
;
2511 scm_whash_get_handle (SCM whash
, SCM key
)
2513 scm_c_issue_deprecation_warning
2514 ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
2516 return scm_hashq_get_handle (whash
, key
);
2520 SCM_WHASHFOUNDP (SCM h
)
2522 scm_c_issue_deprecation_warning
2523 ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
2525 return scm_is_true (h
);
2529 SCM_WHASHREF (SCM whash
, SCM handle
)
2531 scm_c_issue_deprecation_warning
2532 ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
2534 return SCM_CDR (handle
);
2538 SCM_WHASHSET (SCM whash
, SCM handle
, SCM obj
)
2540 scm_c_issue_deprecation_warning
2541 ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
2543 SCM_SETCDR (handle
, obj
);
2547 scm_whash_create_handle (SCM whash
, SCM key
)
2549 scm_c_issue_deprecation_warning
2550 ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
2552 return scm_hashq_create_handle_x (whash
, key
, SCM_UNSPECIFIED
);
2556 scm_whash_lookup (SCM whash
, SCM obj
)
2558 scm_c_issue_deprecation_warning
2559 ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
2561 return scm_hashq_ref (whash
, obj
, SCM_BOOL_F
);
2565 scm_whash_insert (SCM whash
, SCM key
, SCM obj
)
2567 scm_c_issue_deprecation_warning
2568 ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
2570 scm_hashq_set_x (whash
, key
, obj
);
2575 SCM scm_struct_table
= SCM_BOOL_F
;
2578 scm_struct_create_handle (SCM obj
)
2580 scm_c_issue_deprecation_warning
2581 ("`scm_struct_create_handle' is deprecated, and has no effect.");
2583 return scm_cons (obj
, scm_cons (SCM_BOOL_F
, SCM_BOOL_F
));
2589 scm_internal_dynamic_wind (scm_t_guard before
,
2597 scm_c_issue_deprecation_warning
2598 ("`scm_internal_dynamic_wind' is deprecated. "
2599 "Use the `scm_dynwind_begin' / `scm_dynwind_end' API instead.");
2601 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
2602 scm_dynwind_rewind_handler (before
, guard_data
, SCM_F_WIND_EXPLICITLY
);
2603 scm_dynwind_unwind_handler (after
, guard_data
, SCM_F_WIND_EXPLICITLY
);
2604 ans
= inner (inner_data
);
2612 scm_immutable_cell (scm_t_bits car
, scm_t_bits cdr
)
2614 scm_c_issue_deprecation_warning
2615 ("scm_immutable_cell is deprecated. Use scm_cell instead.");
2617 return scm_cell (car
, cdr
);
2621 scm_immutable_double_cell (scm_t_bits car
, scm_t_bits cbr
,
2622 scm_t_bits ccr
, scm_t_bits cdr
)
2624 scm_c_issue_deprecation_warning
2625 ("scm_immutable_double_cell is deprecated. Use scm_double_cell instead.");
2627 return scm_double_cell (car
, cbr
, ccr
, cdr
);
2634 scm_i_deprecated_asrtgo (scm_t_bits condition
)
2636 scm_c_issue_deprecation_warning
2637 ("SCM_ASRTGO is deprecated. Use `if (!condition) goto label;' directly.");
2648 * looks up the variable bound to SYM according to PROC. PROC should be
2649 * a `eval closure' of some module.
2651 * When no binding exists, and DEFINEP is true, create a new binding
2652 * with a initial value of SCM_UNDEFINED. Return `#f' when DEFINEP as
2653 * false and no binding exists.
2655 * When PROC is `#f', it is ignored and the binding is searched for in
2656 * the scm_pre_modules_obarray (a `eq' hash table).
2660 scm_sym2var (SCM sym
, SCM proc
, SCM definep
)
2661 #define FUNC_NAME "scm_sym2var"
2665 if (scm_is_true (definep
))
2666 scm_c_issue_deprecation_warning
2667 ("scm_sym2var is deprecated. Use scm_define or scm_module_define\n"
2668 "to define variables. In some rare cases you may need\n"
2669 "scm_module_ensure_local_variable.");
2671 scm_c_issue_deprecation_warning
2672 ("scm_sym2var is deprecated. Use scm_module_variable to look up\n"
2675 if (SCM_NIMP (proc
))
2677 if (SCM_EVAL_CLOSURE_P (proc
))
2679 /* Bypass evaluator in the standard case. */
2680 var
= scm_eval_closure_lookup (proc
, sym
, definep
);
2683 var
= scm_call_2 (proc
, sym
, definep
);
2687 if (scm_is_false (definep
))
2688 var
= scm_module_variable (scm_the_root_module (), sym
);
2690 var
= scm_module_ensure_local_variable (scm_the_root_module (), sym
);
2693 if (scm_is_true (var
) && !SCM_VARIABLEP (var
))
2694 SCM_MISC_ERROR ("~S is not bound to a variable", scm_list_1 (sym
));
2701 scm_lookup_closure_module (SCM proc
)
2703 scm_c_issue_deprecation_warning
2704 ("Eval closures are deprecated. See \"Accessing Modules From C\" in\n"
2705 "the manual, for replacements.");
2707 if (scm_is_false (proc
))
2708 return scm_the_root_module ();
2709 else if (SCM_EVAL_CLOSURE_P (proc
))
2710 return SCM_PACK (SCM_SMOB_DATA (proc
));
2712 /* FIXME: The `module' property is no longer set on eval closures, as it
2713 introduced a circular reference that precludes garbage collection of
2714 modules with the current weak hash table semantics (see
2715 http://lists.gnu.org/archive/html/guile-devel/2009-01/msg00102.html and
2716 http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/2465
2717 for details). Since it doesn't appear to be used (only in this
2718 function, which has 1 caller), we no longer extend
2719 `set-module-eval-closure!' to set the `module' property. */
2724 scm_module_lookup_closure (SCM module
)
2726 scm_c_issue_deprecation_warning
2727 ("Eval closures are deprecated. See \"Accessing Modules From C\" in\n"
2728 "the manual, for replacements.");
2730 if (scm_is_false (module
))
2733 return SCM_MODULE_EVAL_CLOSURE (module
);
2737 scm_current_module_lookup_closure ()
2739 scm_c_issue_deprecation_warning
2740 ("Eval closures are deprecated. See \"Accessing Modules From C\" in\n"
2741 "the manual, for replacements.");
2743 if (scm_module_system_booted_p
)
2744 return scm_module_lookup_closure (scm_current_module ());
2749 scm_t_bits scm_tc16_eval_closure
;
2751 #define SCM_F_EVAL_CLOSURE_INTERFACE (1<<0)
2752 #define SCM_EVAL_CLOSURE_INTERFACE_P(e) \
2753 (SCM_SMOB_FLAGS (e) & SCM_F_EVAL_CLOSURE_INTERFACE)
2755 /* NOTE: This function may be called by a smob application
2756 or from another C function directly. */
2758 scm_eval_closure_lookup (SCM eclo
, SCM sym
, SCM definep
)
2760 SCM module
= SCM_PACK (SCM_SMOB_DATA (eclo
));
2762 scm_c_issue_deprecation_warning
2763 ("Eval closures are deprecated. See \"Accessing Modules From C\" in\n"
2764 "the manual, for replacements.");
2766 if (scm_is_true (definep
))
2768 if (SCM_EVAL_CLOSURE_INTERFACE_P (eclo
))
2770 return scm_module_ensure_local_variable (module
, sym
);
2773 return scm_module_variable (module
, sym
);
2776 SCM_DEFINE (scm_standard_eval_closure
, "standard-eval-closure", 1, 0, 0,
2778 "Return an eval closure for the module @var{module}.")
2779 #define FUNC_NAME s_scm_standard_eval_closure
2781 scm_c_issue_deprecation_warning
2782 ("Eval closures are deprecated. See \"Accessing Modules From C\" in\n"
2783 "the manual, for replacements.");
2785 SCM_RETURN_NEWSMOB (scm_tc16_eval_closure
, SCM_UNPACK (module
));
2790 SCM_DEFINE (scm_standard_interface_eval_closure
,
2791 "standard-interface-eval-closure", 1, 0, 0,
2793 "Return a interface eval closure for the module @var{module}. "
2794 "Such a closure does not allow new bindings to be added.")
2795 #define FUNC_NAME s_scm_standard_interface_eval_closure
2797 scm_c_issue_deprecation_warning
2798 ("Eval closures are deprecated. See \"Accessing Modules From C\" in\n"
2799 "the manual, for replacements.");
2801 SCM_RETURN_NEWSMOB (scm_tc16_eval_closure
| (SCM_F_EVAL_CLOSURE_INTERFACE
<<16),
2802 SCM_UNPACK (module
));
2806 SCM_DEFINE (scm_eval_closure_module
,
2807 "eval-closure-module", 1, 0, 0,
2809 "Return the module associated with this eval closure.")
2810 /* the idea is that eval closures are really not the way to do things, they're
2811 superfluous given our module system. this function lets mmacros migrate away
2812 from eval closures. */
2813 #define FUNC_NAME s_scm_eval_closure_module
2815 scm_c_issue_deprecation_warning
2816 ("Eval closures are deprecated. See \"Accessing Modules From C\" in\n"
2817 "the manual, for replacements.");
2819 SCM_MAKE_VALIDATE_MSG (SCM_ARG1
, eval_closure
, EVAL_CLOSURE_P
,
2821 return SCM_SMOB_OBJECT (eval_closure
);
2828 SCM_DEFINE (scm_struct_vtable_tag
, "struct-vtable-tag", 1, 0, 0,
2830 "Return the vtable tag of the structure @var{handle}.")
2831 #define FUNC_NAME s_scm_struct_vtable_tag
2833 SCM_VALIDATE_VTABLE (1, handle
);
2834 scm_c_issue_deprecation_warning
2835 ("struct-vtable-tag is deprecated. What were you doing with it anyway?");
2837 return scm_from_unsigned_integer
2838 (((scm_t_bits
)SCM_STRUCT_DATA (handle
)) >> 3);
2845 SCM_DEFINE (scm_generalized_vector_p
, "generalized-vector?", 1, 0, 0,
2847 "Return @code{#t} if @var{obj} is a vector, string,\n"
2848 "bitvector, or uniform numeric vector.")
2849 #define FUNC_NAME s_scm_generalized_vector_p
2851 scm_c_issue_deprecation_warning
2852 ("generalized-vector? is deprecated. Use array? and check the "
2853 "array-rank instead.");
2854 return scm_from_bool (scm_is_generalized_vector (obj
));
2858 SCM_DEFINE (scm_generalized_vector_length
, "generalized-vector-length", 1, 0, 0,
2860 "Return the length of the generalized vector @var{v}.")
2861 #define FUNC_NAME s_scm_generalized_vector_length
2863 scm_c_issue_deprecation_warning
2864 ("generalized-vector-length is deprecated. Use array-length instead.");
2865 return scm_from_size_t (scm_c_generalized_vector_length (v
));
2869 SCM_DEFINE (scm_generalized_vector_ref
, "generalized-vector-ref", 2, 0, 0,
2871 "Return the element at index @var{idx} of the\n"
2872 "generalized vector @var{v}.")
2873 #define FUNC_NAME s_scm_generalized_vector_ref
2875 scm_c_issue_deprecation_warning
2876 ("generalized-vector-ref is deprecated. Use array-ref instead.");
2877 return scm_c_generalized_vector_ref (v
, scm_to_size_t (idx
));
2881 SCM_DEFINE (scm_generalized_vector_set_x
, "generalized-vector-set!", 3, 0, 0,
2882 (SCM v
, SCM idx
, SCM val
),
2883 "Set the element at index @var{idx} of the\n"
2884 "generalized vector @var{v} to @var{val}.")
2885 #define FUNC_NAME s_scm_generalized_vector_set_x
2887 scm_c_issue_deprecation_warning
2888 ("generalized-vector-set! is deprecated. Use array-set! instead. "
2889 "Note the change in argument order!");
2890 scm_c_generalized_vector_set_x (v
, scm_to_size_t (idx
), val
);
2891 return SCM_UNSPECIFIED
;
2895 SCM_DEFINE (scm_generalized_vector_to_list
, "generalized-vector->list", 1, 0, 0,
2897 "Return a new list whose elements are the elements of the\n"
2898 "generalized vector @var{v}.")
2899 #define FUNC_NAME s_scm_generalized_vector_to_list
2901 /* FIXME: This duplicates `array_to_list'. */
2905 scm_t_array_handle h
;
2907 scm_c_issue_deprecation_warning
2908 ("generalized-vector->list is deprecated. Use array->list instead.");
2910 scm_generalized_vector_get_handle (v
, &h
);
2912 i
= h
.dims
[0].ubnd
- h
.dims
[0].lbnd
+ 1;
2913 inc
= h
.dims
[0].inc
;
2914 pos
= (i
- 1) * inc
;
2916 for (; i
> 0; i
--, pos
-= inc
)
2917 ret
= scm_cons (h
.impl
->vref (&h
, h
.base
+ pos
), ret
);
2919 scm_array_handle_release (&h
);
2928 scm_c_program_source (SCM program
, size_t ip
)
2930 scm_c_issue_deprecation_warning
2931 ("scm_c_program_source is deprecated. Use scm_program_source instead.");
2933 return scm_program_source (program
, scm_from_size_t (ip
), SCM_UNBOUND
);
2940 scm_i_init_deprecated ()
2942 properties_whash
= scm_make_weak_key_hash_table (SCM_UNDEFINED
);
2943 scm_struct_table
= scm_make_hash_table (SCM_UNDEFINED
);
2944 scm_tc16_eval_closure
= scm_make_smob_type ("eval-closure", 0);
2945 scm_set_smob_apply (scm_tc16_eval_closure
, scm_eval_closure_lookup
, 2, 0, 0);
2947 #include "libguile/deprecated.x"