From 5ab7c1ccd9734a344e772003a7500ab107907b4e Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Sun, 22 Jan 2012 10:54:24 +0900
Subject: [PATCH] adding print-stack-trace primitive

---
 include/chibi/sexp.h | 1 +
 opcodes.c            | 3 ++-
 vm.c                 | 5 +++++
 3 files changed, 8 insertions(+), 1 deletion(-)

diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h
index 320af63e..30e021e4 100755
--- a/include/chibi/sexp.h
+++ b/include/chibi/sexp.h
@@ -1278,6 +1278,7 @@ SEXP_API sexp sexp_type_exception (sexp ctx, sexp self, sexp_uint_t type_id, sex
 SEXP_API sexp sexp_xtype_exception (sexp ctx, sexp self, const char *msg, sexp x);
 SEXP_API sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end);
 SEXP_API sexp sexp_print_exception_op (sexp ctx, sexp self, sexp_sint_t n, sexp exn, sexp out);
+SEXP_API sexp sexp_stack_trace_op (sexp ctx, sexp self, sexp_sint_t n, sexp out);
 SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args);
 SEXP_API sexp sexp_apply1 (sexp ctx, sexp f, sexp x);
 SEXP_API sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, int flags, sexp_proc1 f, sexp data);
diff --git a/opcodes.c b/opcodes.c
index 0173c83c..990b5bf7 100644
--- a/opcodes.c
+++ b/opcodes.c
@@ -154,7 +154,8 @@ _FN1(_I(SEXP_ENV), _I(SEXP_FIXNUM), "scheme-report-environment", 0, sexp_make_st
 _FN2OPTP(_I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_ENV), "compile", (sexp)"interaction-environment", sexp_compile_op),
 _FN2OPTP(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_ENV), "load", (sexp)"interaction-environment", sexp_load_op),
 _FN4(SEXP_VOID, _I(SEXP_ENV), _I(SEXP_ENV), _I(SEXP_OBJECT), "%import", 0, sexp_env_import_op),
-_FN2(SEXP_VOID, _I(SEXP_EXCEPTION), _I(SEXP_OPORT), "print-exception", 0, sexp_print_exception_op),
+_FN2OPTP(SEXP_VOID, _I(SEXP_EXCEPTION), _I(SEXP_OPORT), "print-exception", (sexp)"current-error-port", sexp_print_exception_op),
+_FN1OPTP(SEXP_VOID, _I(SEXP_OPORT), "print-stack-trace", (sexp)"current-error-port", sexp_stack_trace_op),
 _FN1(_I(SEXP_OBJECT), _I(SEXP_EXCEPTION), "exception-type", 0, sexp_exception_type_op),
 _FN2OPT(_I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_CHAR), "make-string", sexp_make_character(' '), sexp_make_string_op),
 _FN2OPT(_I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "make-bytevector", SEXP_ZERO, sexp_make_bytes_op),
diff --git a/vm.c b/vm.c
index 7ad10436..0f5c6627 100644
--- a/vm.c
+++ b/vm.c
@@ -48,6 +48,11 @@ void sexp_stack_trace (sexp ctx, sexp out) {
   }
 }
 
+sexp sexp_stack_trace_op (sexp ctx, sexp self, sexp_sint_t n, sexp out) {
+  sexp_stack_trace(ctx, out);
+  return SEXP_UNDEF;
+}
+
 /************************* code generation ****************************/
 
 static void bytecode_preserve (sexp ctx, sexp obj) {