[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-11-186-gd
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-11-186-gd286c8c |
|
Date: |
Thu, 15 Jul 2010 18:23:12 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=d286c8ce342abc6b647ccf5a68b292fe13ec5cb8
The branch, master has been updated
via d286c8ce342abc6b647ccf5a68b292fe13ec5cb8 (commit)
via 45f84beaf18e95f838ae12ab4d577987ae4e8382 (commit)
via 41e49280f37c350106719d8377a4dc2390caf0a7 (commit)
via 867961f9798d2d6ce398e2d14f8a9dc01cf20ae7 (commit)
via 218d580ab46481f3a44ada1897bbe0ae8abf3e54 (commit)
from f4b879e03bf217f4114b2997c0bdbe1008daf874 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit d286c8ce342abc6b647ccf5a68b292fe13ec5cb8
Author: Andy Wingo <address@hidden>
Date: Thu Jul 15 12:47:58 2010 +0200
don't re-print the error by default in call-with-error-handling
* module/system/repl/error-handling.scm (call-with-error-handling):
Previous post-error changed to "report"; now "catch", the default,
doesn't re-print the error.
commit 45f84beaf18e95f838ae12ab4d577987ae4e8382
Author: Andy Wingo <address@hidden>
Date: Thu Jul 15 12:46:02 2010 +0200
error-handling tweak
* module/system/repl/error-handling.scm (call-with-error-handling):
Remove extra newline.
commit 41e49280f37c350106719d8377a4dc2390caf0a7
Author: Andy Wingo <address@hidden>
Date: Thu Jul 15 12:44:15 2010 +0200
better error reporting from the vm
* libguile/vm-engine.c: Add func_name local, for error reporting.
(vm_error_apply_to_non_list): New error case.
(vm_error_wrong_type_arg): Remove this generic error case.
(vm_error_wrong_type_apply): Remove FUNC_NAME -- no sense in seeing
"vm-debug-engine" in the error report.
(vm_error_not_a_pair, vm_error_not_a_bytevector)
(vm_error_not_a_struct, vm_error_not_a_thunk): Use func_name instead
of FUNC_NAME, so we can indicate what caused the error.
* libguile/vm-i-scheme.c (VM_VALIDATE_CONS, car, cdr, set-car!)
(set-cdr!): Indicate provenance of errors.
(VM_VALIDATE_STRUCT, struct-vtable):
(VM_VALIDATE_BYTEVECTOR, BV_FIXABLE_INT_REF, BV_INT_REF)
(BV_FLOAT_REF, BV_FIXABLE_INT_SET, BV_INT_SET, BV_FLOAT_SET): Same.
* libguile/vm-i-system.c (apply, tail-apply): Use
vm_error_apply_to_non_list.
commit 867961f9798d2d6ce398e2d14f8a9dc01cf20ae7
Author: Andy Wingo <address@hidden>
Date: Thu Jul 15 12:13:15 2010 +0200
pass a frame to display-error in system repl error-handling
* module/system/repl/error-handling.scm (call-with-error-handling): Pass
a frame to display-error.
commit 218d580ab46481f3a44ada1897bbe0ae8abf3e54
Author: Andy Wingo <address@hidden>
Date: Thu Jul 15 12:11:34 2010 +0200
display-error takes a frame, shows source if possible
* libguile/backtrace.h:
* libguile/backtrace.c (scm_display_error): Change "stack" arg to
"frame". Still accept stacks for backward compatibility.
(display_header, display_error_body): Show the source of the error, if
possible.
-----------------------------------------------------------------------
Summary of changes:
libguile/backtrace.c | 58 +++++++++++++++++++++++++++-----
libguile/backtrace.h | 2 +-
libguile/vm-engine.c | 17 +++++----
libguile/vm-i-scheme.c | 33 ++++++++++--------
libguile/vm-i-system.c | 14 ++++++--
module/system/repl/error-handling.scm | 47 +++++++++++++-------------
6 files changed, 111 insertions(+), 60 deletions(-)
diff --git a/libguile/backtrace.c b/libguile/backtrace.c
index aac7e20..b4bee73 100644
--- a/libguile/backtrace.c
+++ b/libguile/backtrace.c
@@ -33,6 +33,7 @@
#include <io.h>
#endif
+#include "libguile/deprecation.h"
#include "libguile/stacks.h"
#include "libguile/srcprop.h"
#include "libguile/struct.h"
@@ -74,7 +75,28 @@
static void
display_header (SCM source, SCM port)
{
- scm_puts ("ERROR", port);
+ if (scm_is_true (source))
+ {
+ /* source := (addr . (filename . (line . column))) */
+ SCM fname = scm_cadr (source);
+ SCM line = scm_caddr (source);
+ SCM col = scm_cdddr (source);
+
+ if (scm_is_true (fname))
+ scm_prin1 (fname, port, 0);
+ else
+ scm_puts ("<unnamed port>", port);
+
+ if (scm_is_true (line) && scm_is_true (col))
+ {
+ scm_putc (':', port);
+ scm_intprint (scm_to_long (line) + 1, 10, port);
+ scm_putc (':', port);
+ scm_intprint (scm_to_long (col) + 1, 10, port);
+ }
+ }
+ else
+ scm_puts ("ERROR", port);
scm_puts (": ", port);
}
@@ -162,7 +184,7 @@ display_expression (SCM frame, SCM pname, SCM source, SCM
port)
}
struct display_error_args {
- SCM stack;
+ SCM frame;
SCM port;
SCM subr;
SCM message;
@@ -173,14 +195,20 @@ struct display_error_args {
static SCM
display_error_body (struct display_error_args *a)
{
- SCM current_frame = SCM_BOOL_F;
SCM source = SCM_BOOL_F;
SCM pname = a->subr;
+ if (SCM_FRAMEP (a->frame))
+ {
+ source = scm_frame_source (a->frame);
+ if (!scm_is_symbol (pname) && !scm_is_string (pname))
+ pname = scm_procedure_name (scm_frame_procedure (a->frame));
+ }
+
if (scm_is_symbol (pname) || scm_is_string (pname))
{
display_header (source, a->port);
- display_expression (current_frame, pname, source, a->port);
+ display_expression (a->frame, pname, source, a->port);
}
display_header (source, a->port);
scm_display_error_message (a->message, a->args, a->port);
@@ -217,11 +245,23 @@ display_error_handler (struct display_error_handler_data
*data,
* code should rather use the function scm_display_error.
*/
void
-scm_i_display_error (SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM
rest)
+scm_i_display_error (SCM frame, SCM port, SCM subr, SCM message, SCM args, SCM
rest)
{
struct display_error_args a;
struct display_error_handler_data data;
- a.stack = stack;
+
+ if (SCM_FRAMEP (frame))
+ a.frame = frame;
+#if SCM_ENABLE_DEPRECATED
+ else if (SCM_STACKP (frame))
+ {
+ scm_c_issue_deprecation_warning
+ ("Passing a stack to display-error is deprecated. Pass a frame
instead.");
+ a.frame = scm_stack_ref (frame, SCM_INUM0);
+ }
+#endif
+ else
+ a.frame = SCM_BOOL_F;
a.port = port;
a.subr = subr;
a.message = message;
@@ -236,9 +276,9 @@ scm_i_display_error (SCM stack, SCM port, SCM subr, SCM
message, SCM args, SCM r
SCM_DEFINE (scm_display_error, "display-error", 6, 0, 0,
- (SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM rest),
+ (SCM frame, SCM port, SCM subr, SCM message, SCM args, SCM rest),
"Display an error message to the output port @var{port}.\n"
- "@var{stack} is the saved stack for the error, @var{subr} is\n"
+ "@var{frame} is the frame in which the error occurred, @var{subr}
is\n"
"the name of the procedure in which the error occurred and\n"
"@var{message} is the actual error message, which may contain\n"
"formatting instructions. These will format the arguments in\n"
@@ -248,7 +288,7 @@ SCM_DEFINE (scm_display_error, "display-error", 6, 0, 0,
{
SCM_VALIDATE_OUTPUT_PORT (2, port);
- scm_i_display_error (stack, port, subr, message, args, rest);
+ scm_i_display_error (frame, port, subr, message, args, rest);
return SCM_UNSPECIFIED;
}
diff --git a/libguile/backtrace.h b/libguile/backtrace.h
index 22d2d03..a8c6cc5 100644
--- a/libguile/backtrace.h
+++ b/libguile/backtrace.h
@@ -28,7 +28,7 @@
SCM_API void scm_display_error_message (SCM message, SCM args, SCM port);
SCM_INTERNAL void scm_i_display_error (SCM stack, SCM port, SCM subr,
SCM message, SCM args, SCM rest);
-SCM_API SCM scm_display_error (SCM stack, SCM port, SCM subr, SCM message, SCM
args, SCM rest);
+SCM_API SCM scm_display_error (SCM frame, SCM port, SCM subr, SCM message, SCM
args, SCM rest);
SCM_API SCM scm_display_application (SCM frame, SCM port, SCM indent);
SCM_API SCM scm_display_backtrace (SCM stack, SCM port, SCM first, SCM depth);
SCM_API SCM scm_display_backtrace_with_highlights (SCM stack, SCM port, SCM
first, SCM depth, SCM highlights);
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 11981ba..7f4641a 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 2b0c782..15c5e8f 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 cedd43f..11f8ae0 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);
diff --git a/module/system/repl/error-handling.scm
b/module/system/repl/error-handling.scm
index 28b5428..db0beeb 100644
--- a/module/system/repl/error-handling.scm
+++ b/module/system/repl/error-handling.scm
@@ -50,7 +50,7 @@
(lambda () (%start-stack #t thunk))
(case post-error
- ((catch)
+ ((report)
(lambda (key . args)
(if (memq key pass-keys)
(apply throw key args)
@@ -67,6 +67,10 @@
(format err "\nERROR: uncaught throw to `~a', args: ~a\n"
key args)))
(if #f #f)))))
+ ((catch)
+ (lambda (key . args)
+ (if (memq key pass-keys)
+ (apply throw key args))))
(else
(if (procedure? post-error)
post-error ; a handler proc
@@ -75,34 +79,31 @@
(case on-error
((debug)
(lambda (key . args)
- (let ((stack (make-stack #t)))
+ (let* ((tag (and (pair? (fluid-ref %stacks))
+ (cdar (fluid-ref %stacks))))
+ (stack (narrow-stack->vector
+ (make-stack #t)
+ ;; Cut three frames from the top of the stack:
+ ;; make-stack, this one, and the throw handler.
+ 3
+ ;; Narrow the end of the stack to the most recent
+ ;; start-stack.
+ tag
+ ;; And one more frame, because %start-stack invoking
+ ;; the start-stack thunk has its own frame too.
+ 0 (and tag 1)))
+ (debug (make-debug stack 0)))
(with-saved-ports
(lambda ()
(pmatch args
((,subr ,msg ,args . ,rest)
- (format #t "Throw to key `~a':\n" key)
- (display-error stack (current-output-port) subr msg args
rest))
+ (display-error (vector-ref stack 0) (current-output-port)
+ subr msg args rest))
(else
(format #t "Throw to key `~a' with args `~s'." key args)))
- (format #t "Entering a new prompt. Type `,bt' for a backtrace")
- (format #t " or `,q' to return to the old prompt.\n")
- (let ((debug
- (make-debug
- (let ((tag (and (pair? (fluid-ref %stacks))
- (cdar (fluid-ref %stacks)))))
- (narrow-stack->vector
- stack
- ;; Cut three frames from the top of the stack:
- ;; make-stack, this one, and the throw handler.
- 3
- ;; Narrow the end of the stack to the most recent
- ;; start-stack.
- tag
- ;; And one more frame, because %start-stack invoking
- ;; the start-stack thunk has its own frame too.
- 0 (and tag 1)))
- 0)))
- ((@ (system repl repl) start-repl) #:debug debug)))))))
+ (format #t "Entering a new prompt. ")
+ (format #t "Type `,bt' for a backtrace or `,q' to continue.\n")
+ ((@ (system repl repl) start-repl) #:debug debug))))))
((pass)
(lambda (key . args)
;; fall through to rethrow
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-11-186-gd286c8c,
Andy Wingo <=