mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-15 16:20:17 +02:00
Code Activity

* filesys.c (scsm_sys_stat): don't SIGSEGV if argument is an

Browse source 
integer (assuming for now accepting an integer is a good thing).

	* error.c, fports.c: replace use of %S in lgh_error args with %s.
	%S will be used instead for write'ing arguments.

	* unif.c (scm_transpose_array): change arguments in the SCM_WNA
	asserts.  fix a few other asserts.
	(scm_aind, scm_enclose_array, scm_array_in_bounds_p,
	scm_uniform_vector_ref,	scm_array_set_x,
	scm_dimensions_to_unform_array): change args in
	SCM_WNA SCM_ASSERTS and change scm_wta's to scm_wrong_num_args.
	strop.c (scm_substring_move_left_x, scm_substring_move_right_x,
	scm_substring_fill_x): likewise.
	gsubr.c (scm_gsubr_apply): likewise.
	eval.c (SCM_APPLY): likewise.

	* eval.c (4 places): replace scm_everr with lgh_error or
	scm_wrong_num_args.

	* error.c, error.h (scm_wrong_num_args, scm_wrong_type_arg,
	scm_memory_error): new procedures.
*	scm_everr: deleted.  can use scm_wta, dropping first two args.
	scm_error: convert NULL subr to SCM_BOOL_F.

	* __scm.h: don't define SCM_STACK_OVFLOW, SCM_EXIT, SCM_ARG6, SCM_ARG7,
	SCM_ARGERR.

	* stackchk.c (scm_report_stack_overflow): use lgh_error instead
	of scm_wta.

	* error.c, error.h: new error keys: scm_arg_type_key,
	scm_args_number_key, scm_memory_alloc_key, scm_stack_overflow_key,
	scm_misc_error_key.
	scm_wta: reimplement using lgh_error instead of scm_everr.
This commit is contained in:
Gary Houston 1996-09-19 09:08:07 +00:00
parent 2194b6f00e
commit f5bf2977c6
11 changed files with 241 additions and 149 deletions
Download patch file Download diff file Expand all files Collapse all files

38
libguile/ChangeLog
View file

@ -1,3 +1,41 @@
Thu Sep 19 00:00:29 1996 Gary Houston <ghouston@actrix.gen.nz>
* filesys.c (scsm_sys_stat): don't SIGSEGV if argument is an
integer (assuming for now accepting an integer is a good thing).
* error.c, fports.c: replace use of %S in lgh_error args with %s.
%S will be used instead for write'ing arguments.
* unif.c (scm_transpose_array): change arguments in the SCM_WNA
asserts. fix a few other asserts.
(scm_aind, scm_enclose_array, scm_array_in_bounds_p,
scm_uniform_vector_ref, scm_array_set_x,
scm_dimensions_to_unform_array): change args in
SCM_WNA SCM_ASSERTS and change scm_wta's to scm_wrong_num_args.
strop.c (scm_substring_move_left_x, scm_substring_move_right_x,
scm_substring_fill_x): likewise.
gsubr.c (scm_gsubr_apply): likewise.
eval.c (SCM_APPLY): likewise.
* eval.c (4 places): replace scm_everr with lgh_error or
scm_wrong_num_args.
* error.c, error.h (scm_wrong_num_args, scm_wrong_type_arg,
scm_memory_error): new procedures.
* scm_everr: deleted. can use scm_wta, dropping first two args.
scm_error: convert NULL subr to SCM_BOOL_F.
* __scm.h: don't define SCM_STACK_OVFLOW, SCM_EXIT, SCM_ARG6, SCM_ARG7,
SCM_ARGERR.
* stackchk.c (scm_report_stack_overflow): use lgh_error instead
of scm_wta.
* error.c, error.h: new error keys: scm_arg_type_key,
scm_args_number_key, scm_memory_alloc_key, scm_stack_overflow_key,
scm_misc_error_key.
scm_wta: reimplement using lgh_error instead of scm_everr.
Wed Sep 18 17:13:35 1996 Mikael Djurfeldt <mdj@kenneth> Wed Sep 18 17:13:35 1996 Mikael Djurfeldt <mdj@kenneth>
* gdbint.c: scm_lread now has one more argument. * gdbint.c: scm_lread now has one more argument.

11
libguile/__scm.h
View file

@ -321,11 +321,12 @@ extern unsigned int scm_async_clock;
#define SCM_ARG3 3 #define SCM_ARG3 3
#define SCM_ARG4 4 #define SCM_ARG4 4
#define SCM_ARG5 5 #define SCM_ARG5 5
#define SCM_ARG6 6 /* #define SCM_ARG6 6
#define SCM_ARG7 7 #define SCM_ARG7 7 */
#define SCM_ARGERR(X) ((X) < SCM_WNA \ /* #define SCM_ARGERR(X) ((X) < SCM_WNA \
? (char *)(X) \ ? (char *)(X) \
: "wrong type argument") : "wrong type argument")
*/
/* Following must match entry indexes in scm_errmsgs[]. /* Following must match entry indexes in scm_errmsgs[].
* Also, SCM_WNA must follow the last SCM_ARGn in sequence. * Also, SCM_WNA must follow the last SCM_ARGn in sequence.
@ -334,8 +335,8 @@ extern unsigned int scm_async_clock;
/* #define SCM_OVSCM_FLOW 9 */ /* #define SCM_OVSCM_FLOW 9 */
#define SCM_OUTOFRANGE 10 #define SCM_OUTOFRANGE 10
#define SCM_NALLOC 11 #define SCM_NALLOC 11
#define SCM_STACK_OVFLOW 12 /* #define SCM_STACK_OVFLOW 12 */
#define SCM_EXIT 13 /* #define SCM_EXIT 13 */
/* (...still matching scm_errmsgs) These /* (...still matching scm_errmsgs) These

203
libguile/error.c
View file

@ -63,16 +63,11 @@
*/ */
int scm_ints_disabled = 1; int scm_ints_disabled = 1;
extern int errno; extern int errno;
#ifdef __STDC__
static void
err_head (char *str)
#else
static void static void
err_head (str) err_head (str)
char *str; char *str;
#endif
{ {
int oerrno = errno; int oerrno = errno;
if (SCM_NIMP (scm_cur_outp)) if (SCM_NIMP (scm_cur_outp))
@ -100,14 +95,9 @@ err_head (str)
SCM_PROC(s_errno, "errno", 0, 1, 0, scm_errno); SCM_PROC(s_errno, "errno", 0, 1, 0, scm_errno);
#ifdef __STDC__ SCM
SCM
scm_errno (SCM arg)
#else
SCM
scm_errno (arg) scm_errno (arg)
SCM arg; SCM arg;
#endif
{ {
int old = errno; int old = errno;
if (!SCM_UNBNDP (arg)) if (!SCM_UNBNDP (arg))
@ -121,82 +111,19 @@ scm_errno (arg)
} }
SCM_PROC(s_perror, "perror", 1, 0, 0, scm_perror); SCM_PROC(s_perror, "perror", 1, 0, 0, scm_perror);
#ifdef __STDC__
SCM
scm_perror (SCM arg)
#else
SCM SCM
scm_perror (arg) scm_perror (arg)
SCM arg; SCM arg;
#endif
{ {
SCM_ASSERT (SCM_NIMP (arg) && SCM_STRINGP (arg), arg, SCM_ARG1, s_perror); SCM_ASSERT (SCM_NIMP (arg) && SCM_STRINGP (arg), arg, SCM_ARG1, s_perror);
err_head (SCM_CHARS (arg)); err_head (SCM_CHARS (arg));
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
#ifdef __STDC__
void
scm_everr (SCM exp, SCM env, SCM arg, char *pos, char *s_subr)
#else
void
scm_everr (exp, env, arg, pos, s_subr)
SCM exp;
SCM env;
SCM arg;
char *pos;
char *s_subr;
#endif
{
SCM desc;
SCM args;
if ((~0x1fL) & (long) pos)
desc = scm_makfrom0str (pos);
else
desc = SCM_MAKINUM ((long)pos);
{
SCM sym;
if (!s_subr || !*s_subr)
sym = SCM_BOOL_F;
else
sym = SCM_CAR (scm_intern0 (s_subr));
args = scm_listify (desc, sym, arg, SCM_UNDEFINED);
}
/* (throw (quote scm_system-error_key) <desc> <proc-name> arg)
*
* <desc> is a string or an integer (see %%system-errors).
* <proc-name> is a symbol or #f in some annoying cases (e.g. cddr).
*/
scm_ithrow (scm_system_error_key, args, 1);
/* No return, but just in case: */
write (2, "unhandled system error", sizeof ("unhandled system error") - 1);
exit (1);
}
#ifdef __STDC__
SCM
scm_wta (SCM arg, char *pos, char *s_subr)
#else
SCM
scm_wta (arg, pos, s_subr)
SCM arg;
char *pos;
char *s_subr;
#endif
{
scm_everr (SCM_UNDEFINED, SCM_EOL, arg, pos, s_subr);
return SCM_UNSPECIFIED;
}
void (*scm_error_callback) () = 0; void (*scm_error_callback) () = 0;
/* all errors thrown from C should pass through here. */
/* also known as lgh_error. */
void void
scm_error (key, subr, message, args, rest) scm_error (key, subr, message, args, rest)
SCM key; SCM key;
@ -209,7 +136,7 @@ scm_error (key, subr, message, args, rest)
if (scm_error_callback) if (scm_error_callback)
(*scm_error_callback) (key, subr, message, args, rest); (*scm_error_callback) (key, subr, message, args, rest);
arg_list = scm_listify (scm_makfrom0str (subr), arg_list = scm_listify (subr ? scm_makfrom0str (subr) : SCM_BOOL_F,
scm_makfrom0str (message), scm_makfrom0str (message),
args, args,
rest, rest,
@ -227,15 +154,19 @@ scm_error (key, subr, message, args, rest)
SCM scm_system_error_key; SCM scm_system_error_key;
SCM scm_num_overflow_key; SCM scm_num_overflow_key;
SCM scm_out_of_range_key; SCM scm_out_of_range_key;
SCM scm_arg_type_key;
SCM scm_args_number_key;
SCM scm_memory_alloc_key;
SCM scm_stack_overflow_key;
SCM scm_misc_error_key;
/* various convenient interfaces to lgh_error. */
void void
scm_syserror (subr) scm_syserror (subr)
char *subr; char *subr;
{ {
lgh_error (scm_system_error_key, lgh_error (scm_system_error_key,
subr, subr,
"%S", "%s",
scm_listify (scm_makfrom0str (strerror (errno)), scm_listify (scm_makfrom0str (strerror (errno)),
SCM_UNDEFINED), SCM_UNDEFINED),
scm_listify (SCM_MAKINUM (errno), SCM_UNDEFINED)); scm_listify (SCM_MAKINUM (errno), SCM_UNDEFINED));
@ -261,7 +192,7 @@ scm_sysmissing (subr)
#ifdef ENOSYS #ifdef ENOSYS
lgh_error (scm_system_error_key, lgh_error (scm_system_error_key,
subr, subr,
"%S", "%s",
scm_listify (scm_makfrom0str (strerror (ENOSYS)), SCM_UNDEFINED), scm_listify (scm_makfrom0str (strerror (ENOSYS)), SCM_UNDEFINED),
scm_listify (SCM_MAKINUM (ENOSYS), SCM_UNDEFINED)); scm_listify (SCM_MAKINUM (ENOSYS), SCM_UNDEFINED));
#else #else
@ -295,14 +226,104 @@ scm_out_of_range (subr, bad_value)
scm_listify (bad_value, SCM_UNDEFINED), scm_listify (bad_value, SCM_UNDEFINED),
SCM_BOOL_F); SCM_BOOL_F);
} }
#ifdef __STDC__
void void
scm_init_error (void) scm_wrong_num_args (proc)
#else SCM proc;
{
lgh_error (scm_args_number_key,
NULL,
"Wrong number of arguments to %s",
scm_listify (proc, SCM_UNDEFINED),
SCM_BOOL_F);
}
void
scm_wrong_type_arg (subr, pos, bad_value)
char *subr;
int pos;
SCM bad_value;
{
lgh_error (scm_arg_type_key,
subr,
(pos == 0) ? "Wrong type argument: %S"
: "Wrong type argument in position %s: %S",
(pos == 0) ? scm_listify (bad_value, SCM_UNDEFINED)
: scm_listify (SCM_MAKINUM (pos), bad_value, SCM_UNDEFINED),
SCM_BOOL_F);
}
void
scm_memory_error (subr)
char *subr;
{
lgh_error (scm_memory_alloc_key,
subr,
"Memory allocation error",
SCM_BOOL_F,
SCM_BOOL_F);
}
/* implements the SCM_ASSERT interface. */
SCM
scm_wta (arg, pos, s_subr)
SCM arg;
char *pos;
char *s_subr;
{
if (!s_subr || !*s_subr)
s_subr = NULL;
if ((~0x1fL) & (long) pos)
{
/* error string supplied. */
lgh_error (scm_misc_error_key,
s_subr,
pos,
SCM_BOOL_F,
SCM_BOOL_F);
}
else
{
/* numerical error code. */
int error = (long) pos;
switch (error)
{
case SCM_ARGn:
scm_wrong_type_arg (s_subr, 0, arg);
case SCM_ARG1:
scm_wrong_type_arg (s_subr, 1, arg);
case SCM_ARG2:
scm_wrong_type_arg (s_subr, 2, arg);
case SCM_ARG3:
scm_wrong_type_arg (s_subr, 3, arg);
case SCM_ARG4:
scm_wrong_type_arg (s_subr, 4, arg);
case SCM_ARG5:
scm_wrong_type_arg (s_subr, 5, arg);
case SCM_WNA:
scm_wrong_num_args (arg);
case SCM_OUTOFRANGE:
scm_out_of_range (s_subr, arg);
case SCM_NALLOC:
scm_memory_error (s_subr);
default:
/* this shouldn't happen. */
lgh_error (scm_misc_error_key,
s_subr,
"Unknown error",
SCM_BOOL_F,
SCM_BOOL_F);
}
}
return SCM_UNSPECIFIED;
}
/* obsolete interface: scm_everr (exp, env, arg, pos, s_subr)
was equivalent to scm_wta (arg, pos, s_subr) */
void void
scm_init_error () scm_init_error ()
#endif
{ {
scm_system_error_key scm_system_error_key
= scm_permanent_object (SCM_CAR (scm_intern0 ("system-error"))); = scm_permanent_object (SCM_CAR (scm_intern0 ("system-error")));
@ -310,6 +331,16 @@ scm_init_error ()
= scm_permanent_object (SCM_CAR (scm_intern0 ("numerical-overflow"))); = scm_permanent_object (SCM_CAR (scm_intern0 ("numerical-overflow")));
scm_out_of_range_key scm_out_of_range_key
= scm_permanent_object (SCM_CAR (scm_intern0 ("out-of-range"))); = scm_permanent_object (SCM_CAR (scm_intern0 ("out-of-range")));
scm_arg_type_key
= scm_permanent_object (SCM_CAR (scm_intern0 ("wrong-type-arg")));
scm_args_number_key
= scm_permanent_object (SCM_CAR (scm_intern0 ("wrong-number-of-args")));
scm_memory_alloc_key
= scm_permanent_object (SCM_CAR (scm_intern0 ("memory-allocation-error")));
scm_stack_overflow_key
= scm_permanent_object (SCM_CAR (scm_intern0 ("stack-overflow")));
scm_misc_error_key
= scm_permanent_object (SCM_CAR (scm_intern0 ("misc-error")));
#include "error.x" #include "error.x"
} }

34
libguile/error.h
View file

@ -51,9 +51,16 @@ extern int scm_ints_disabled;
extern SCM scm_system_error_key; extern SCM scm_system_error_key;
extern SCM scm_num_overflow_key; extern SCM scm_num_overflow_key;
extern SCM scm_out_of_range_key; extern SCM scm_out_of_range_key;
extern SCM scm_arg_type_key;
extern SCM scm_args_number_key;
extern SCM scm_memory_alloc_key;
extern SCM scm_stack_overflow_key;
extern SCM scm_misc_error_key;
extern SCM scm_errno SCM_P ((SCM arg));
extern SCM scm_perror SCM_P ((SCM arg));
extern void scm_error SCM_P ((SCM key, char *subr, char *message, extern void scm_error SCM_P ((SCM key, char *subr, char *message,
SCM args, SCM rest)); SCM args, SCM rest));
extern void (*scm_error_callback) SCM_P ((SCM key, char *subr, extern void (*scm_error_callback) SCM_P ((SCM key, char *subr,
@ -63,27 +70,10 @@ extern void scm_syserror_msg SCM_P ((char *subr, char *message, SCM args));
extern void scm_sysmissing SCM_P ((char *subr)); extern void scm_sysmissing SCM_P ((char *subr));
extern void scm_num_overflow SCM_P ((char *subr)); extern void scm_num_overflow SCM_P ((char *subr));
extern void scm_out_of_range SCM_P ((char *subr, SCM bad_value)); extern void scm_out_of_range SCM_P ((char *subr, SCM bad_value));
extern void scm_wrong_num_args SCM_P ((SCM proc));
#ifdef __STDC__ extern void scm_wrong_type_arg SCM_P ((char *subr, int pos, SCM bad_value));
extern int scm_handle_it (int i); extern void scm_memory_error SCM_P ((char *subr));
extern void scm_warn (char *str1, char *str2); extern SCM scm_wta SCM_P ((SCM arg, char *pos, char *s_subr));
extern SCM scm_errno (SCM arg); extern void scm_init_error SCM_P ((void));
extern SCM scm_perror (SCM arg);
extern void scm_def_err_response (void);
extern void scm_everr (SCM exp, SCM env, SCM arg, char *pos, char *s_subr);
extern SCM scm_wta (SCM arg, char *pos, char *s_subr);
extern void scm_init_error (void);
#else /* STDC */
extern int scm_handle_it ();
extern void scm_warn ();
extern SCM scm_errno ();
extern SCM scm_perror ();
extern void scm_def_err_response ();
extern void scm_everr ();
extern SCM scm_wta ();
extern void scm_init_error ();
#endif /* STDC */
#endif /* ERRORH */ #endif /* ERRORH */

34
libguile/eval.c
View file

@ -242,11 +242,14 @@ scm_lookupcar (vloc, genv)
{ {
var = SCM_CAR (var); var = SCM_CAR (var);
errout: errout:
scm_everr (vloc, genv, var, /* scm_everr (vloc, genv,...) */
(SCM_NULLP (env) lgh_error (scm_misc_error_key,
? "unbound variable: " NULL,
: "damaged environment"), SCM_NULLP (env)
""); ? "Unbound variable: %S"
: "Damaged environment: %S",
scm_listify (var, SCM_UNDEFINED),
SCM_BOOL_F);
} }
#endif #endif
SCM_CAR (vloc) = var + 1; SCM_CAR (vloc) = var + 1;
@ -432,8 +435,12 @@ scm_m_vref (xorig, env)
ASSYNT (1 == scm_ilength (x), xorig, s_expression, s_vref); ASSYNT (1 == scm_ilength (x), xorig, s_expression, s_vref);
if (SCM_NIMP(x) && UDSCM_VARIABLEP (SCM_CAR (x))) if (SCM_NIMP(x) && UDSCM_VARIABLEP (SCM_CAR (x)))
{ {
scm_everr (SCM_UNDEFINED, env, SCM_CAR(SCM_CDR(x)), s_variable, /* scm_everr (SCM_UNDEFINED, env,..., "global variable reference") */
"global variable reference"); lgh_error (scm_misc_error_key,
NULL,
"Bad variable: %S",
scm_listify (SCM_CAR (SCM_CDR (x)), SCM_UNDEFINED),
SCM_BOOL_F);
} }
ASSYNT (SCM_NIMP(x) && DEFSCM_VARIABLEP (SCM_CAR (x)), ASSYNT (SCM_NIMP(x) && DEFSCM_VARIABLEP (SCM_CAR (x)),
xorig, s_variable, s_vref); xorig, s_variable, s_vref);
@ -1848,8 +1855,12 @@ dispatch:
default: default:
proc = x; proc = x;
badfun: badfun:
scm_everr (x, env, proc, "Wrong type to apply: ", ""); /* scm_everr (x, env,...) */
lgh_error (scm_misc_error_key,
NULL,
"Wrong type to apply: %S",
scm_listify (proc, SCM_UNDEFINED),
SCM_BOOL_F);
case scm_tc7_vector: case scm_tc7_vector:
case scm_tc7_wvect: case scm_tc7_wvect:
case scm_tc7_bvect: case scm_tc7_bvect:
@ -2021,7 +2032,8 @@ evapply:
umwrongnumargs: umwrongnumargs:
unmemocar (x, env); unmemocar (x, env);
wrongnumargs: wrongnumargs:
scm_everr (x, env, proc, (char *) SCM_WNA, ""); /* scm_everr (x, env,...) */
scm_wrong_num_args (proc);
default: default:
/* handle macros here */ /* handle macros here */
goto badfun; goto badfun;
@ -2582,7 +2594,7 @@ tail:
goto tail; goto tail;
#endif #endif
wrongnumargs: wrongnumargs:
scm_wta (proc, (char *) SCM_WNA, "apply"); scm_wrong_num_args (proc);
default: default:
badproc: badproc:
scm_wta (proc, (char *) SCM_ARG1, "apply"); scm_wta (proc, (char *) SCM_ARG1, "apply");

1
libguile/filesys.c
View file

@ -594,7 +594,6 @@ scm_sys_stat (fd_or_path)
if (SCM_INUMP (fd_or_path)) if (SCM_INUMP (fd_or_path))
{ {
SCM_ASSERT (SCM_OPFPORTP (fd_or_path), fd_or_path, SCM_ARG1, s_sys_stat);
rv = SCM_INUM (fd_or_path); rv = SCM_INUM (fd_or_path);
SCM_SYSCALL (rv = fstat (rv, &stat_temp)); SCM_SYSCALL (rv = fstat (rv, &stat_temp));
} }

2
libguile/fports.c
View file

@ -171,7 +171,7 @@ scm_open_file (filename, modes)
SCM_SYSCALL (f = fopen (file, mode)); SCM_SYSCALL (f = fopen (file, mode));
if (!f) if (!f)
{ {
scm_syserror_msg (s_open_file, "%S: %S", scm_syserror_msg (s_open_file, "%s: %S",
scm_listify (scm_makfrom0str (strerror (errno)), scm_listify (scm_makfrom0str (strerror (errno)),
filename, filename,
SCM_UNDEFINED)); SCM_UNDEFINED));

2
libguile/gsubr.c
View file

@ -130,7 +130,7 @@ scm_gsubr_apply(args)
for (i = 0; i < GSUBR_REQ(typ); i++) { for (i = 0; i < GSUBR_REQ(typ); i++) {
#ifndef RECKLESS #ifndef RECKLESS
if (SCM_IMP(args)) if (SCM_IMP(args))
scm_wta(SCM_UNDEFINED, (char *)SCM_WNA, SCM_CHARS(SCM_SNAME(GSUBR_PROC(self)))); scm_wrong_num_args (SCM_SNAME(GSUBR_PROC(self)));
#endif #endif
v[i] = SCM_CAR(args); v[i] = SCM_CAR(args);
args = SCM_CDR(args); args = SCM_CDR(args);

6
libguile/stackchk.c
View file

@ -57,7 +57,11 @@ void
scm_report_stack_overflow () scm_report_stack_overflow ()
{ {
scm_stack_checking_enabled_p = 0; scm_stack_checking_enabled_p = 0;
scm_wta (SCM_UNDEFINED, (char *) SCM_STACK_OVFLOW, NULL); lgh_error (scm_stack_overflow_key,
NULL,
"Stack overflow",
SCM_BOOL_F,
SCM_BOOL_F);
} }
#endif #endif

9
libguile/strop.c
View file

@ -200,7 +200,8 @@ scm_substring_move_left_x (str1, start1, args)
{ {
SCM end1, str2, start2; SCM end1, str2, start2;
long i, j, e; long i, j, e;
SCM_ASSERT (3==scm_ilength (args), args, SCM_WNA, s_substring_move_left_x); SCM_ASSERT (3==scm_ilength (args), scm_makfrom0str (s_substring_move_left_x),
SCM_WNA, NULL);
end1 = SCM_CAR (args); args = SCM_CDR (args); end1 = SCM_CAR (args); args = SCM_CDR (args);
str2 = SCM_CAR (args); args = SCM_CDR (args); str2 = SCM_CAR (args); args = SCM_CDR (args);
start2 = SCM_CAR (args); start2 = SCM_CAR (args);
@ -233,7 +234,8 @@ scm_substring_move_right_x (str1, start1, args)
{ {
SCM end1, str2, start2; SCM end1, str2, start2;
long i, j, e; long i, j, e;
SCM_ASSERT (3==scm_ilength (args), args, SCM_WNA, s_substring_move_right_x); SCM_ASSERT (3==scm_ilength (args),
scm_makfrom0str (s_substring_move_right_x), SCM_WNA, NULL);
end1 = SCM_CAR (args); args = SCM_CDR (args); end1 = SCM_CAR (args); args = SCM_CDR (args);
str2 = SCM_CAR (args); args = SCM_CDR (args); str2 = SCM_CAR (args); args = SCM_CDR (args);
start2 = SCM_CAR (args); start2 = SCM_CAR (args);
@ -267,7 +269,8 @@ scm_substring_fill_x (str, start, args)
SCM end, fill; SCM end, fill;
long i, e; long i, e;
char c; char c;
SCM_ASSERT (2==scm_ilength (args), args, SCM_WNA, s_substring_fill_x); SCM_ASSERT (2==scm_ilength (args), scm_makfrom0str (s_substring_fill_x),
SCM_WNA, NULL);
end = SCM_CAR (args); args = SCM_CDR (args); end = SCM_CAR (args); args = SCM_CDR (args);
fill = SCM_CAR (args); fill = SCM_CAR (args);
SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_substring_fill_x); SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_substring_fill_x);

50
libguile/unif.c
View file

@ -503,7 +503,7 @@ scm_aind (ra, args, what)
if (SCM_INUMP (args)) if (SCM_INUMP (args))
{ {
SCM_ASSERT (1 == k, SCM_UNDEFINED, SCM_WNA, what); SCM_ASSERT (1 == k, scm_makfrom0str (what), SCM_WNA, NULL);
return pos + (SCM_INUM (args) - s->lbnd) * (s->inc); return pos + (SCM_INUM (args) - s->lbnd) * (s->inc);
} }
while (k && SCM_NIMP (args)) while (k && SCM_NIMP (args))
@ -517,7 +517,8 @@ scm_aind (ra, args, what)
k--; k--;
s++; s++;
} }
SCM_ASSERT (0 == k && SCM_NULLP (args), SCM_UNDEFINED, SCM_WNA, what); SCM_ASSERT (0 == k && SCM_NULLP (args), scm_makfrom0str (what), SCM_WNA,
NULL);
return pos; return pos;
} }
@ -610,7 +611,9 @@ scm_dimensions_to_uniform_array (dims, prot, fill)
answer = scm_make_uve (SCM_INUM (dims), prot); answer = scm_make_uve (SCM_INUM (dims), prot);
if (SCM_NNULLP (fill)) if (SCM_NNULLP (fill))
{ {
SCM_ASSERT (1 == scm_ilength (fill), fill, SCM_WNA, s_dimensions_to_uniform_array); SCM_ASSERT (1 == scm_ilength (fill),
scm_makfrom0str (s_dimensions_to_uniform_array),
SCM_WNA, NULL);
scm_array_fill_x (answer, SCM_CAR (fill)); scm_array_fill_x (answer, SCM_CAR (fill));
} }
else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot)) else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot))
@ -666,7 +669,9 @@ scm_dimensions_to_uniform_array (dims, prot, fill)
} }
if (SCM_NNULLP (fill)) if (SCM_NNULLP (fill))
{ {
SCM_ASSERT (1 == scm_ilength (fill), fill, SCM_WNA, s_dimensions_to_uniform_array); SCM_ASSERT (1 == scm_ilength (fill),
scm_makfrom0str (s_dimensions_to_uniform_array), SCM_WNA,
NULL);
scm_array_fill_x (ra, SCM_CAR (fill)); scm_array_fill_x (ra, SCM_CAR (fill));
} }
else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot)) else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot))
@ -836,14 +841,15 @@ scm_transpose_array (args)
SCM ra, res, vargs, *ve = &vargs; SCM ra, res, vargs, *ve = &vargs;
scm_array_dim *s, *r; scm_array_dim *s, *r;
int ndim, i, k; int ndim, i, k;
SCM_ASSERT (SCM_NIMP (args), SCM_UNDEFINED, SCM_WNA, s_transpose_array); SCM_ASSERT (SCM_NNULLP (args), scm_makfrom0str (s_transpose_array),
SCM_WNA, NULL);
ra = SCM_CAR (args); ra = SCM_CAR (args);
SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, s_transpose_array);
args = SCM_CDR (args); args = SCM_CDR (args);
switch SCM_TYP7 switch (SCM_TYP7 (ra))
(ra)
{ {
default: default:
badarg:scm_wta (ra, (char *) SCM_ARG1, s_transpose_array); badarg:scm_wta (ra, (char *) SCM_ARGn, s_transpose_array);
case scm_tc7_bvect: case scm_tc7_bvect:
case scm_tc7_string: case scm_tc7_string:
case scm_tc7_byvect: case scm_tc7_byvect:
@ -856,14 +862,19 @@ scm_transpose_array (args)
#ifdef LONGLONGS #ifdef LONGLONGS
case scm_tc7_llvect: case scm_tc7_llvect:
#endif #endif
SCM_ASSERT (SCM_NIMP (args) && SCM_NULLP (SCM_CDR (args)), SCM_UNDEFINED, SCM_WNA, s_transpose_array); SCM_ASSERT (SCM_NIMP (args) && SCM_NULLP (SCM_CDR (args)),
SCM_ASSERT (SCM_INUM0 == SCM_CAR (args), SCM_CAR (args), SCM_ARG1, s_transpose_array); scm_makfrom0str (s_transpose_array), SCM_WNA, NULL);
SCM_ASSERT (SCM_INUMP (SCM_CAR (args)), SCM_CAR (args), SCM_ARG2,
s_transpose_array);
SCM_ASSERT (SCM_INUM0 == SCM_CAR (args), SCM_CAR (args), SCM_OUTOFRANGE,
s_transpose_array);
return ra; return ra;
case scm_tc7_smob: case scm_tc7_smob:
SCM_ASRTGO (SCM_ARRAYP (ra), badarg); SCM_ASRTGO (SCM_ARRAYP (ra), badarg);
vargs = scm_vector (args); vargs = scm_vector (args);
SCM_ASSERT (SCM_LENGTH (vargs) == SCM_ARRAY_NDIM (ra), SCM_UNDEFINED, SCM_WNA, s_transpose_array); SCM_ASSERT (SCM_LENGTH (vargs) == SCM_ARRAY_NDIM (ra),
ve = SCM_VELTS (vargs); scm_makfrom0str (s_transpose_array), SCM_WNA, NULL);
ve = SCM_VELTS (vargs);
ndim = 0; ndim = 0;
for (k = 0; k < SCM_ARRAY_NDIM (ra); k++) for (k = 0; k < SCM_ARRAY_NDIM (ra); k++)
{ {
@ -926,7 +937,8 @@ scm_enclose_array (axes)
SCM axv, ra, res, ra_inr; SCM axv, ra, res, ra_inr;
scm_array_dim vdim, *s = &vdim; scm_array_dim vdim, *s = &vdim;
int ndim, j, k, ninr, noutr; int ndim, j, k, ninr, noutr;
SCM_ASSERT (SCM_NIMP (axes), SCM_UNDEFINED, SCM_WNA, s_enclose_array); SCM_ASSERT (SCM_NIMP (axes), scm_makfrom0str (s_enclose_array), SCM_WNA,
NULL);
ra = SCM_CAR (axes); ra = SCM_CAR (axes);
axes = SCM_CDR (axes); axes = SCM_CDR (axes);
if (SCM_NULLP (axes)) if (SCM_NULLP (axes))
@ -970,7 +982,8 @@ scm_enclose_array (axes)
} }
noutr = ndim - ninr; noutr = ndim - ninr;
axv = scm_make_string (SCM_MAKINUM (ndim), SCM_MAKICHR (0)); axv = scm_make_string (SCM_MAKINUM (ndim), SCM_MAKICHR (0));
SCM_ASSERT (0 <= noutr && 0 <= ninr, SCM_UNDEFINED, SCM_WNA, s_enclose_array); SCM_ASSERT (0 <= noutr && 0 <= ninr, scm_makfrom0str (s_enclose_array),
SCM_WNA, NULL);
res = scm_make_ra (noutr); res = scm_make_ra (noutr);
SCM_ARRAY_BASE (res) = SCM_ARRAY_BASE (ra_inr); SCM_ARRAY_BASE (res) = SCM_ARRAY_BASE (ra_inr);
SCM_ARRAY_V (res) = ra_inr; SCM_ARRAY_V (res) = ra_inr;
@ -1013,7 +1026,8 @@ scm_array_in_bounds_p (args)
register scm_sizet k; register scm_sizet k;
register long j; register long j;
scm_array_dim *s; scm_array_dim *s;
SCM_ASSERT (SCM_NIMP (args), args, SCM_WNA, s_array_in_bounds_p); SCM_ASSERT (SCM_NIMP (args), scm_makfrom0str (s_array_in_bounds_p),
SCM_WNA, NULL);
v = SCM_CAR (args); v = SCM_CAR (args);
args = SCM_CDR (args); args = SCM_CDR (args);
SCM_ASRTGO (SCM_NIMP (v), badarg1); SCM_ASRTGO (SCM_NIMP (v), badarg1);
@ -1031,7 +1045,7 @@ tail:
{ {
default: default:
badarg1:scm_wta (v, (char *) SCM_ARG1, s_array_in_bounds_p); badarg1:scm_wta (v, (char *) SCM_ARG1, s_array_in_bounds_p);
wna:scm_wta (args, (char *) SCM_WNA, s_array_in_bounds_p); wna: scm_wrong_num_args (scm_makfrom0str (s_array_in_bounds_p));
case scm_tc7_smob: case scm_tc7_smob:
k = SCM_ARRAY_NDIM (v); k = SCM_ARRAY_NDIM (v);
s = SCM_ARRAY_DIMS (v); s = SCM_ARRAY_DIMS (v);
@ -1129,7 +1143,7 @@ scm_uniform_vector_ref (v, args)
return v; return v;
badarg:scm_wta (v, (char *) SCM_ARG1, s_uniform_vector_ref); badarg:scm_wta (v, (char *) SCM_ARG1, s_uniform_vector_ref);
outrng:scm_out_of_range (s_uniform_vector_ref, SCM_MAKINUM (pos)); outrng:scm_out_of_range (s_uniform_vector_ref, SCM_MAKINUM (pos));
wna:scm_wta (SCM_UNDEFINED, (char *) SCM_WNA, s_uniform_vector_ref); wna: scm_wrong_num_args (scm_makfrom0str (s_uniform_vector_ref));
case scm_tc7_smob: case scm_tc7_smob:
{ /* enclosed */ { /* enclosed */
int k = SCM_ARRAY_NDIM (v); int k = SCM_ARRAY_NDIM (v);
@ -1322,7 +1336,7 @@ scm_array_set_x (v, obj, args)
default: default:
badarg1:scm_wta (v, (char *) SCM_ARG1, s_array_set_x); badarg1:scm_wta (v, (char *) SCM_ARG1, s_array_set_x);
outrng:scm_out_of_range (s_array_set_x, SCM_MAKINUM (pos)); outrng:scm_out_of_range (s_array_set_x, SCM_MAKINUM (pos));
wna:scm_wta (SCM_UNDEFINED, (char *) SCM_WNA, s_array_set_x); wna: scm_wrong_num_args (scm_makfrom0str (s_array_set_x));
case scm_tc7_smob: /* enclosed */ case scm_tc7_smob: /* enclosed */
goto badarg1; goto badarg1;
case scm_tc7_bvect: case scm_tc7_bvect: