diff options
-rw-r--r-- | libguile/vm-engine.c | 17 | ||||
-rw-r--r-- | libguile/vm-i-scheme.c | 33 | ||||
-rw-r--r-- | libguile/vm-i-system.c | 14 |
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); |