summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/vm-engine.c17
-rw-r--r--libguile/vm-i-scheme.c33
-rw-r--r--libguile/vm-i-system.c14
3 files changed, 37 insertions, 27 deletions
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 11981ba30..7f4641a07 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -53,6 +53,7 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
/* Internal variables */
int nvalues = 0;
+ const char *func_name = NULL; /* used for error reporting */
SCM finish_args; /* used both for returns: both in error
and normal situations */
#ifdef HAVE_LABELS_AS_VALUES
@@ -142,9 +143,9 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
err_msg = scm_from_locale_string ("VM: Unbound variable: ~s");
goto vm_error;
- vm_error_wrong_type_arg:
- err_msg = scm_from_locale_string ("VM: Wrong type argument");
- finish_args = SCM_EOL;
+ vm_error_apply_to_non_list:
+ scm_error (scm_arg_type_key, "apply", "Apply to non-list: ~S",
+ finish_args, finish_args);
goto vm_error;
vm_error_kwargs_length_not_even:
@@ -181,7 +182,7 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
vm_error_wrong_type_apply:
SYNC_ALL ();
- scm_error (scm_arg_type_key, FUNC_NAME, "Wrong type to apply: ~S",
+ scm_error (scm_arg_type_key, NULL, "Wrong type to apply: ~S",
scm_list_1 (program), scm_list_1 (program));
goto vm_error;
@@ -205,25 +206,25 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
vm_error_not_a_pair:
SYNC_ALL ();
- scm_wrong_type_arg_msg (FUNC_NAME, 1, finish_args, "pair");
+ scm_wrong_type_arg_msg (func_name, 1, finish_args, "pair");
/* shouldn't get here */
goto vm_error;
vm_error_not_a_bytevector:
SYNC_ALL ();
- scm_wrong_type_arg_msg (FUNC_NAME, 1, finish_args, "bytevector");
+ scm_wrong_type_arg_msg (func_name, 1, finish_args, "bytevector");
/* shouldn't get here */
goto vm_error;
vm_error_not_a_struct:
SYNC_ALL ();
- scm_wrong_type_arg_msg (FUNC_NAME, 1, finish_args, "struct");
+ scm_wrong_type_arg_msg (func_name, 1, finish_args, "struct");
/* shouldn't get here */
goto vm_error;
vm_error_not_a_thunk:
SYNC_ALL ();
- scm_wrong_type_arg_msg (FUNC_NAME, 1, finish_args, "thunk");
+ scm_wrong_type_arg_msg ("dynamic-wind", 1, finish_args, "thunk");
/* shouldn't get here */
goto vm_error;
diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index 2b0c78220..15c5e8fdb 100644
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -111,23 +111,24 @@ VM_DEFINE_FUNCTION (138, cons, "cons", 2)
RETURN (x);
}
-#define VM_VALIDATE_CONS(x) \
+#define VM_VALIDATE_CONS(x, proc) \
if (SCM_UNLIKELY (!scm_is_pair (x))) \
- { finish_args = x; \
+ { func_name = proc; \
+ finish_args = x; \
goto vm_error_not_a_pair; \
}
VM_DEFINE_FUNCTION (139, car, "car", 1)
{
ARGS1 (x);
- VM_VALIDATE_CONS (x);
+ VM_VALIDATE_CONS (x, "car");
RETURN (SCM_CAR (x));
}
VM_DEFINE_FUNCTION (140, cdr, "cdr", 1)
{
ARGS1 (x);
- VM_VALIDATE_CONS (x);
+ VM_VALIDATE_CONS (x, "cdr");
RETURN (SCM_CDR (x));
}
@@ -136,7 +137,7 @@ VM_DEFINE_INSTRUCTION (141, set_car, "set-car!", 0, 2, 0)
SCM x, y;
POP (y);
POP (x);
- VM_VALIDATE_CONS (x);
+ VM_VALIDATE_CONS (x, "set-car!");
SCM_SETCAR (x, y);
NEXT;
}
@@ -146,7 +147,7 @@ VM_DEFINE_INSTRUCTION (142, set_cdr, "set-cdr!", 0, 2, 0)
SCM x, y;
POP (y);
POP (x);
- VM_VALIDATE_CONS (x);
+ VM_VALIDATE_CONS (x, "set-cdr!");
SCM_SETCDR (x, y);
NEXT;
}
@@ -397,9 +398,10 @@ VM_DEFINE_INSTRUCTION (163, make_array, "make-array", 3, -1, 1)
/*
* Structs
*/
-#define VM_VALIDATE_STRUCT(obj) \
+#define VM_VALIDATE_STRUCT(obj, proc) \
if (SCM_UNLIKELY (!SCM_STRUCTP (obj))) \
{ \
+ func_name = proc; \
finish_args = (obj); \
goto vm_error_not_a_struct; \
}
@@ -413,7 +415,7 @@ VM_DEFINE_FUNCTION (164, struct_p, "struct?", 1)
VM_DEFINE_FUNCTION (165, struct_vtable, "struct-vtable", 1)
{
ARGS1 (obj);
- VM_VALIDATE_STRUCT (obj);
+ VM_VALIDATE_STRUCT (obj, "struct_vtable");
RETURN (SCM_STRUCT_VTABLE (obj));
}
@@ -543,11 +545,12 @@ VM_DEFINE_INSTRUCTION (171, slot_set, "slot-set", 0, 3, 0)
/*
* Bytevectors
*/
-#define VM_VALIDATE_BYTEVECTOR(x) \
+#define VM_VALIDATE_BYTEVECTOR(x, proc) \
do \
{ \
if (SCM_UNLIKELY (!SCM_BYTEVECTOR_P (x))) \
{ \
+ func_name = proc; \
finish_args = x; \
goto vm_error_not_a_bytevector; \
} \
@@ -596,7 +599,7 @@ BV_REF_WITH_ENDIANNESS (f64, ieee_double)
const scm_t_ ## type *int_ptr; \
ARGS2 (bv, idx); \
\
- VM_VALIDATE_BYTEVECTOR (bv); \
+ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
i = SCM_I_INUM (idx); \
int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
\
@@ -618,7 +621,7 @@ BV_REF_WITH_ENDIANNESS (f64, ieee_double)
const scm_t_ ## type *int_ptr; \
ARGS2 (bv, idx); \
\
- VM_VALIDATE_BYTEVECTOR (bv); \
+ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
i = SCM_I_INUM (idx); \
int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
\
@@ -649,7 +652,7 @@ BV_REF_WITH_ENDIANNESS (f64, ieee_double)
const type *float_ptr; \
ARGS2 (bv, idx); \
\
- VM_VALIDATE_BYTEVECTOR (bv); \
+ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
i = SCM_I_INUM (idx); \
float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
\
@@ -737,7 +740,7 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double)
scm_t_ ## type *int_ptr; \
\
POP (val); POP (idx); POP (bv); \
- VM_VALIDATE_BYTEVECTOR (bv); \
+ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
i = SCM_I_INUM (idx); \
int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
\
@@ -761,7 +764,7 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double)
scm_t_ ## type *int_ptr; \
\
POP (val); POP (idx); POP (bv); \
- VM_VALIDATE_BYTEVECTOR (bv); \
+ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
i = SCM_I_INUM (idx); \
int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
\
@@ -782,7 +785,7 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double)
type *float_ptr; \
\
POP (val); POP (idx); POP (bv); \
- VM_VALIDATE_BYTEVECTOR (bv); \
+ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
i = SCM_I_INUM (idx); \
float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
\
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index cedd43fd5..11f8ae0d8 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -1094,8 +1094,11 @@ VM_DEFINE_INSTRUCTION (62, apply, "apply", 1, -1, 1)
ASSERT (nargs >= 2);
len = scm_ilength (ls);
- if (len < 0)
- goto vm_error_wrong_type_arg;
+ if (SCM_UNLIKELY (len < 0))
+ {
+ finish_args = ls;
+ goto vm_error_apply_to_non_list;
+ }
PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
@@ -1113,8 +1116,11 @@ VM_DEFINE_INSTRUCTION (63, tail_apply, "tail-apply", 1, -1, 1)
ASSERT (nargs >= 2);
len = scm_ilength (ls);
- if (len < 0)
- goto vm_error_wrong_type_arg;
+ if (SCM_UNLIKELY (len < 0))
+ {
+ finish_args = ls;
+ goto vm_error_apply_to_non_list;
+ }
PUSH_LIST (ls, SCM_NULL_OR_NIL_P);