[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.0-108-gbb455
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.0-108-gbb455e4 |
|
Date: |
Thu, 17 Mar 2011 11:54:24 +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=bb455e4f94d8e339c9b8a69e178110cf3dfa5bcb
The branch, stable-2.0 has been updated
via bb455e4f94d8e339c9b8a69e178110cf3dfa5bcb (commit)
via 17ab1dc3d630dcaeee45e1cb42a8f8699585eea0 (commit)
via 03976fee3b342f9da6fff41bc619c45a12372dfa (commit)
via 148c3317691d5b7d2414179031f87905454cb11a (commit)
from f5fc7e5710438389b21c5c754e959a5554561868 (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 bb455e4f94d8e339c9b8a69e178110cf3dfa5bcb
Author: Andy Wingo <address@hidden>
Date: Thu Mar 17 12:33:58 2011 +0100
allow ,option on-error report instead of debug
* module/system/repl/command.scm:
* module/system/repl/debug.scm (terminal-width): Move terminal-width
here, make it thread-local, and export it.
(print-locals, print-frame, print-frames): Default width to
terminal-width.
* module/system/repl/error-handling.scm (call-with-error-handling): Add
`report' and `backtrace' on-error handlers.
* module/system/repl/common.scm (repl-default-options): Add on-error
REPL option, defaulting to `debug', but which may be changed.
* module/system/repl/repl.scm (run-repl): Pass the #:on-error REPL
option to call-with-error-handling.
commit 17ab1dc3d630dcaeee45e1cb42a8f8699585eea0
Author: Andy Wingo <address@hidden>
Date: Thu Mar 17 11:43:06 2011 +0100
add heap-allocated-since-gc to gc-stats
* libguile/gc.c (scm_gc_stats): Use add bytes_since_gc to the alist,
under "heap-allocated-since-gc", and remove dead code.
commit 03976fee3b342f9da6fff41bc619c45a12372dfa
Author: Andy Wingo <address@hidden>
Date: Thu Mar 17 11:42:50 2011 +0100
fix code that causes warnings on gcc 4.6
* libguile/arrays.c (scm_i_read_array):
* libguile/backtrace.c (display_backtrace_body):
* libguile/filesys.c (scm_readdir)
* libguile/i18n.c (chr_to_case):
* libguile/ports.c (register_finalizer_for_port):
* libguile/posix.c (scm_nice):
* libguile/stacks.c (scm_make_stack): Clean up a number of
set-but-unused vars. Thanks to Douglas Mencken for the report.
* libguile/numbers.c (scm_log, scm_exp): Fix a few #if cases that should
be #ifdef.
commit 148c3317691d5b7d2414179031f87905454cb11a
Author: Andy Wingo <address@hidden>
Date: Thu Mar 17 10:39:02 2011 +0100
add pointer->scm, scm->pointer
* libguile/foreign.c (scm_pointer_to_scm, scm_scm_to_pointer): New
functions, useful to pass and receive SCM values to and from foreign
functions.
* module/system/foreign.scm: Export the new functions.
* doc/ref/api-foreign.texi (Foreign Variables): Add docs.
* test-suite/tests/foreign.test ("pointer<->scm"): Tests.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/api-foreign.texi | 14 +++++++++++
libguile/arrays.c | 4 +--
libguile/backtrace.c | 5 +---
libguile/filesys.c | 5 +---
libguile/foreign.c | 28 +++++++++++++++++++++++
libguile/gc.c | 39 ++++----------------------------
libguile/i18n.c | 14 ++++-------
libguile/numbers.c | 8 ++++--
libguile/ports.c | 3 --
libguile/posix.c | 4 +--
libguile/stacks.c | 2 -
module/system/foreign.scm | 2 +
module/system/repl/command.scm | 14 -----------
module/system/repl/common.scm | 9 ++++++-
module/system/repl/debug.scm | 32 ++++++++++++++++++++++-----
module/system/repl/error-handling.scm | 28 +++++++++++++++++++++++
module/system/repl/repl.scm | 7 ++++-
test-suite/tests/foreign.test | 11 +++++++++
18 files changed, 141 insertions(+), 88 deletions(-)
diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi
index b91439e..b5fdd00 100644
--- a/doc/ref/api-foreign.texi
+++ b/doc/ref/api-foreign.texi
@@ -568,6 +568,20 @@ A foreign pointer whose value is 0.
Return @code{#t} if @var{pointer} is the null pointer, @code{#f} otherwise.
@end deffn
+For the purpose of passing SCM values directly to foreign functions, and
+allowing them to return SCM values, Guile also supports some unsafe
+casting operators.
+
address@hidden {Scheme Procedure} scm->pointer scm
+Return a foreign pointer object with the @code{object-address}
+of @var{scm}.
address@hidden deffn
+
address@hidden {Scheme Procedure} pointer->scm pointer
+Unsafely cast @var{pointer} to a Scheme object.
+Cross your fingers!
address@hidden deffn
+
@node Void Pointers and Byte Access
@subsubsection Void Pointers and Byte Access
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 89f5e9d..6724d00 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006,
2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006,
2009, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -860,7 +860,6 @@ SCM
scm_i_read_array (SCM port, int c)
{
ssize_t rank;
- int got_rank;
char tag[80];
int tag_len;
@@ -888,7 +887,6 @@ scm_i_read_array (SCM port, int c)
return SCM_BOOL_F;
}
rank = 1;
- got_rank = 1;
tag[0] = 'f';
tag_len = 1;
goto continue_reading_tag;
diff --git a/libguile/backtrace.c b/libguile/backtrace.c
index 7140228..db22c17 100644
--- a/libguile/backtrace.c
+++ b/libguile/backtrace.c
@@ -429,7 +429,7 @@ display_backtrace_body (struct display_backtrace_args *a)
#define FUNC_NAME "display_backtrace_body"
{
int n_frames, beg, end, n, i, j;
- int nfield, indent_p, indentation;
+ int nfield, indentation;
SCM frame, sport, print_state;
SCM last_file;
scm_print_state *pstate;
@@ -482,9 +482,6 @@ display_backtrace_body (struct display_backtrace_args *a)
pstate->fancyp = 1;
pstate->highlight_objects = a->highlight_objects;
- /* First find out if it's reasonable to do indentation. */
- indent_p = 0;
-
/* Determine size of frame number field. */
j = end;
for (i = 0; j > 0; ++i) j /= 10;
diff --git a/libguile/filesys.c b/libguile/filesys.c
index 68d90d9..96752bc 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, 2009, 2010
Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, 2009, 2010,
2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -845,7 +845,6 @@ SCM_DEFINE (scm_readdir, "readdir", 1, 0, 0,
{
struct dirent_or_dirent64 de; /* just for sizeof */
DIR *ds = (DIR *) SCM_SMOB_DATA_1 (port);
- size_t namlen;
#ifdef NAME_MAX
char buf [SCM_MAX (sizeof (de),
sizeof (de) - sizeof (de.d_name) + NAME_MAX + 1)];
@@ -865,8 +864,6 @@ SCM_DEFINE (scm_readdir, "readdir", 1, 0, 0,
if (! rdent)
return SCM_EOF_VAL;
- namlen = NAMLEN (rdent);
-
return (rdent ? scm_from_locale_stringn (rdent->d_name, NAMLEN (rdent))
: SCM_EOF_VAL);
}
diff --git a/libguile/foreign.c b/libguile/foreign.c
index 0f07c60..494ab5b 100644
--- a/libguile/foreign.c
+++ b/libguile/foreign.c
@@ -177,6 +177,34 @@ SCM_DEFINE (scm_pointer_address, "pointer-address", 1, 0,
0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_pointer_to_scm, "pointer->scm", 1, 0, 0,
+ (SCM pointer),
+ "Unsafely cast @var{pointer} to a Scheme object.\n"
+ "Cross your fingers!")
+#define FUNC_NAME s_scm_pointer_to_scm
+{
+ SCM_VALIDATE_POINTER (1, pointer);
+
+ return SCM_PACK ((scm_t_bits) SCM_POINTER_VALUE (pointer));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_scm_to_pointer, "scm->pointer", 1, 0, 0,
+ (SCM scm),
+ "Return a foreign pointer object with the @code{object-address}\n"
+ "of @var{scm}.")
+#define FUNC_NAME s_scm_scm_to_pointer
+{
+ SCM ret;
+
+ ret = scm_from_pointer ((void*) SCM_UNPACK (scm), NULL);
+ if (SCM_NIMP (ret))
+ register_weak_reference (ret, scm);
+
+ return ret;
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_pointer_to_bytevector, "pointer->bytevector", 2, 2, 0,
(SCM pointer, SCM len, SCM offset, SCM uvec_type),
"Return a bytevector aliasing the @var{len} bytes pointed\n"
diff --git a/libguile/gc.c b/libguile/gc.c
index f2c0179..8816a61 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -202,23 +202,13 @@ unsigned long scm_gc_ports_collected = 0;
static unsigned long protected_obj_count = 0;
-SCM_SYMBOL (sym_cells_allocated, "cells-allocated");
+SCM_SYMBOL (sym_gc_time_taken, "gc-time-taken");
SCM_SYMBOL (sym_heap_size, "heap-size");
SCM_SYMBOL (sym_heap_free_size, "heap-free-size");
SCM_SYMBOL (sym_heap_total_allocated, "heap-total-allocated");
-SCM_SYMBOL (sym_mallocated, "bytes-malloced");
-SCM_SYMBOL (sym_mtrigger, "gc-malloc-threshold");
-SCM_SYMBOL (sym_heap_segments, "cell-heap-segments");
-SCM_SYMBOL (sym_gc_time_taken, "gc-time-taken");
-SCM_SYMBOL (sym_gc_mark_time_taken, "gc-mark-time-taken");
-SCM_SYMBOL (sym_times, "gc-times");
-SCM_SYMBOL (sym_cells_marked, "cells-marked");
-SCM_SYMBOL (sym_cells_marked_conservatively, "cells-marked-conservatively");
-SCM_SYMBOL (sym_cells_swept, "cells-swept");
-SCM_SYMBOL (sym_malloc_yield, "malloc-yield");
-SCM_SYMBOL (sym_cell_yield, "cell-yield");
+SCM_SYMBOL (sym_heap_allocated_since_gc, "heap-allocated-since-gc");
SCM_SYMBOL (sym_protected_objects, "protected-objects");
-SCM_SYMBOL (sym_total_cells_allocated, "total-cells-allocated");
+SCM_SYMBOL (sym_times, "gc-times");
/* Number of calls to SCM_NEWCELL since startup. */
@@ -283,33 +273,14 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
total_bytes = GC_get_total_bytes ();
gc_times = GC_gc_no;
- /* njrev: can any of these scm_cons's or scm_list_n signal a memory
- error? If so we need a frame here. */
answer =
scm_list_n (scm_cons (sym_gc_time_taken, SCM_INUM0),
-#if 0
- scm_cons (sym_cells_allocated,
- scm_from_ulong (local_scm_cells_allocated)),
- scm_cons (sym_mallocated,
- scm_from_ulong (local_scm_mallocated)),
- scm_cons (sym_mtrigger,
- scm_from_ulong (local_scm_mtrigger)),
- scm_cons (sym_gc_mark_time_taken,
- scm_from_ulong (local_scm_gc_mark_time_taken)),
- scm_cons (sym_cells_marked,
- scm_from_double (local_scm_gc_cells_marked)),
- scm_cons (sym_cells_swept,
- scm_from_double (local_scm_gc_cells_swept)),
- scm_cons (sym_malloc_yield,
- scm_from_long (local_scm_gc_malloc_yield_percentage)),
- scm_cons (sym_cell_yield,
- scm_from_long (local_scm_gc_cell_yield_percentage)),
- scm_cons (sym_heap_segments, heap_segs),
-#endif
scm_cons (sym_heap_size, scm_from_size_t (heap_size)),
scm_cons (sym_heap_free_size, scm_from_size_t (free_bytes)),
scm_cons (sym_heap_total_allocated,
scm_from_size_t (total_bytes)),
+ scm_cons (sym_heap_allocated_since_gc,
+ scm_from_size_t (bytes_since_gc)),
scm_cons (sym_protected_objects,
scm_from_ulong (protected_obj_count)),
scm_cons (sym_times, scm_from_size_t (gc_times)),
diff --git a/libguile/i18n.c b/libguile/i18n.c
index c51df4a..da3c220 100644
--- a/libguile/i18n.c
+++ b/libguile/i18n.c
@@ -1113,23 +1113,19 @@ chr_to_case (SCM chr, scm_t_locale c_locale,
#define FUNC_NAME func_name
{
int ret;
- scm_t_wchar *buf;
+ scm_t_uint32 c;
scm_t_uint32 *convbuf;
size_t convlen;
- SCM str, convchar;
+ SCM convchar;
- str = scm_i_make_wide_string (1, &buf);
- buf[0] = SCM_CHAR (chr);
+ c = SCM_CHAR (chr);
if (c_locale != NULL)
RUN_IN_LOCALE_SECTION (c_locale, ret =
- u32_locale_tocase ((scm_t_uint32 *) buf, 1,
- &convbuf,
- &convlen, func));
+ u32_locale_tocase (&c, 1, &convbuf, &convlen,
func));
else
ret =
- u32_locale_tocase ((scm_t_uint32 *) buf, 1, &convbuf,
- &convlen, func);
+ u32_locale_tocase (&c, 1, &convbuf, &convlen, func);
if (SCM_UNLIKELY (ret != 0))
{
diff --git a/libguile/numbers.c b/libguile/numbers.c
index f8891fa..427e772 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -146,7 +146,7 @@ static double atanh (double x) { return 0.5 * log ((1 + x)
/ (1 - x)); }
#if defined (GUILE_I)
-#if HAVE_COMPLEX_DOUBLE
+#if defined HAVE_COMPLEX_DOUBLE
/* For an SCM object Z which is a complex number (ie. satisfies
SCM_COMPLEXP), return its value as a C level "complex double". */
@@ -9449,7 +9449,8 @@ SCM_PRIMITIVE_GENERIC (scm_log, "log", 1, 0, 0,
{
if (SCM_COMPLEXP (z))
{
-#if HAVE_COMPLEX_DOUBLE && HAVE_CLOG && defined (SCM_COMPLEX_VALUE)
+#if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
+ && defined (SCM_COMPLEX_VALUE)
return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z)));
#else
double re = SCM_COMPLEX_REAL (z);
@@ -9534,7 +9535,8 @@ SCM_PRIMITIVE_GENERIC (scm_exp, "exp", 1, 0, 0,
{
if (SCM_COMPLEXP (z))
{
-#if HAVE_COMPLEX_DOUBLE && HAVE_CEXP && defined (SCM_COMPLEX_VALUE)
+#if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
+ && defined (SCM_COMPLEX_VALUE)
return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z)));
#else
return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z)),
diff --git a/libguile/ports.c b/libguile/ports.c
index a48cc86..8f52e66 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -522,12 +522,9 @@ static void finalize_port (GC_PTR, GC_PTR);
static SCM_C_INLINE_KEYWORD void
register_finalizer_for_port (SCM port)
{
- long port_type;
GC_finalization_proc prev_finalizer;
GC_PTR prev_finalization_data;
- port_type = SCM_TC2PTOBNUM (SCM_CELL_TYPE (port));
-
/* Register a finalizer for PORT so that its iconv CDs get freed and
optionally its type's `free' function gets called. */
GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (port), finalize_port, 0,
diff --git a/libguile/posix.c b/libguile/posix.c
index 97e30df..a5c7262 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -1713,12 +1713,10 @@ SCM_DEFINE (scm_nice, "nice", 1, 0, 0,
"The return value is unspecified.")
#define FUNC_NAME s_scm_nice
{
- int nice_value;
-
/* nice() returns "prio-NZERO" on success or -1 on error, but -1 can arise
from "prio-NZERO", so an error must be detected from errno changed */
errno = 0;
- nice_value = nice (scm_to_int (incr));
+ nice (scm_to_int (incr));
if (errno != 0)
SCM_SYSERROR;
diff --git a/libguile/stacks.c b/libguile/stacks.c
index 267b3c4..31bd91b 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -247,7 +247,6 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
#define FUNC_NAME s_scm_make_stack
{
long n;
- int maxp;
SCM frame;
SCM stack;
SCM inner_cut, outer_cut;
@@ -289,7 +288,6 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
/* Count number of frames. Also get stack id tag and check whether
there are more stackframes than we want to record
(SCM_BACKTRACE_MAXDEPTH). */
- maxp = 0;
n = stack_depth (frame);
/* Make the stack object. */
diff --git a/module/system/foreign.scm b/module/system/foreign.scm
index a657d44..37f9b41 100644
--- a/module/system/foreign.scm
+++ b/module/system/foreign.scm
@@ -37,6 +37,8 @@
null-pointer?
pointer?
make-pointer
+ pointer->scm
+ scm->pointer
pointer-address
pointer->bytevector
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index 685eebb..87ab993 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -71,20 +71,6 @@
(define *show-table*
'((show (warranty w) (copying c) (version v))))
-(define terminal-width
- (let ((set-width #f))
- (case-lambda
- (()
- (or set-width
- (let ((w (false-if-exception (string->number (getenv "COLUMNS")))))
- (and (integer? w) (exact? w) (> w 0) w))
- 72))
- ((w)
- (if (or (not w) (and (integer? w) (exact? w) (> w 0)))
- (set! set-width w)
- (error "Expected a column number (a positive integer)" w))))))
-
-
(define (group-name g) (car g))
(define (group-commands g) (cdr g))
diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index 24a583c..a5267c6 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -121,7 +121,14 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more
details.")
,(value-history-enabled?)
,(lambda (x)
(if x (enable-value-history!) (disable-value-history!))
- (->bool x))))))
+ (->bool x)))
+ (on-error
+ debug
+ ,(let ((vals '(debug backtrace report pass)))
+ (lambda (x)
+ (if (memq x vals)
+ x
+ (error "Bad on-error value ~a; expected one of ~a" x
vals))))))))
(define %make-repl make-repl)
(define* (make-repl lang #:optional debug)
diff --git a/module/system/repl/debug.scm b/module/system/repl/debug.scm
index 46ea6b4..cf40806 100644
--- a/module/system/repl/debug.scm
+++ b/module/system/repl/debug.scm
@@ -1,6 +1,6 @@
;;; Guile VM debugging facilities
-;;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@@ -32,6 +32,7 @@
#:export (<debug>
make-debug debug?
debug-frames debug-index debug-error-message debug-for-trap?
+ terminal-width
print-registers print-locals print-frame print-frames frame->module
stack->vector narrow-stack->vector
frame->stack-vector))
@@ -58,6 +59,25 @@
+;; A fluid, because terminals are usually implicitly associated with
+;; threads.
+;;
+(define terminal-width
+ (let ((set-width (make-fluid)))
+ (case-lambda
+ (()
+ (or (fluid-ref set-width)
+ (let ((w (false-if-exception (string->number (getenv "COLUMNS")))))
+ (and (integer? w) (exact? w) (> w 0) w))
+ 72))
+ ((w)
+ (if (or (not w) (and (integer? w) (exact? w) (> w 0)))
+ (fluid-set! set-width w)
+ (error "Expected a column number (a positive integer)" w))))))
+
+
+
+
(define (reverse-hashq h)
(let ((ret (make-hash-table)))
(hash-for-each
@@ -79,7 +99,7 @@
(print "fp = #x~x\n" (frame-address frame)))
(define* (print-locals frame #:optional (port (current-output-port))
- #:key (width 72) (per-line-prefix " "))
+ #:key (width (terminal-width)) (per-line-prefix " "))
(let ((bindings (frame-bindings frame)))
(cond
((null? bindings)
@@ -99,8 +119,8 @@
(frame-bindings frame))))))
(define* (print-frame frame #:optional (port (current-output-port))
- #:key index (width 72) (full? #f) (last-source #f)
- next-source?)
+ #:key index (width (terminal-width)) (full? #f)
+ (last-source #f) next-source?)
(define (source:pretty-file source)
(if source
(or (source:file source) "current input")
@@ -120,8 +140,8 @@
(define* (print-frames frames
#:optional (port (current-output-port))
- #:key (width 72) (full? #f) (forward? #f) count
- for-trap?)
+ #:key (width (terminal-width)) (full? #f)
+ (forward? #f) count for-trap?)
(let* ((len (vector-length frames))
(lower-idx (if (or (not count) (positive? count))
0
diff --git a/module/system/repl/error-handling.scm
b/module/system/repl/error-handling.scm
index d41dea6..c94db24 100644
--- a/module/system/repl/error-handling.scm
+++ b/module/system/repl/error-handling.scm
@@ -143,6 +143,34 @@
(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))))))
+ ((report)
+ (lambda (key . args)
+ (if (not (memq key pass-keys))
+ (begin
+ (with-saved-ports
+ (lambda ()
+ (run-hook before-error-hook)
+ (print-exception err #f key args)
+ (run-hook after-error-hook)
+ (force-output err)))
+ (if #f #f)))))
+ ((backtrace)
+ (lambda (key . args)
+ (if (not (memq key pass-keys))
+ (let* ((tag (and (pair? (fluid-ref %stacks))
+ (cdar (fluid-ref %stacks))))
+ (frames (narrow-stack->vector
+ (make-stack #t)
+ ;; Narrow as above, for the debugging case.
+ 3 tag 0 (and tag 1))))
+ (with-saved-ports
+ (lambda ()
+ (print-frames frames)
+ (run-hook before-error-hook)
+ (print-exception err #f key args)
+ (run-hook after-error-hook)
+ (force-output err)))
+ (if #f #f)))))
((pass)
(lambda (key . args)
;; fall through to rethrow
diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm
index 39f2319..5bab778 100644
--- a/module/system/repl/repl.scm
+++ b/module/system/repl/repl.scm
@@ -190,8 +190,10 @@
(abort-on-error "parsing expression"
(repl-parse repl exp))))))
(run-hook before-eval-hook exp)
- (with-error-handling
- (with-stack-and-prompt thunk)))
+ (call-with-error-handling
+ (lambda ()
+ (with-stack-and-prompt thunk))
+ #:on-error (repl-option-ref repl 'on-error)))
(lambda (k) (values))))
(lambda l
(for-each (lambda (v)
@@ -199,6 +201,7 @@
l))))
(lambda (k . args)
(abort args))))
+ #:on-error (repl-option-ref repl 'on-error)
#:trap-handler 'disabled)))
(flush-to-newline) ;; consume trailing whitespace
(prompt-loop))))
diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test
index b053639..3ff232e 100644
--- a/test-suite/tests/foreign.test
+++ b/test-suite/tests/foreign.test
@@ -67,6 +67,17 @@
(not (equal? (make-pointer 123) (make-pointer 456)))))
+(with-test-prefix "pointer<->scm"
+
+ (pass-if "immediates"
+ (equal? (pointer->scm (scm->pointer #\newline))
+ #\newline))
+
+ (pass-if "non-immediates"
+ (equal? (pointer->scm (scm->pointer "Hello, world!"))
+ "Hello, world!")))
+
+
(define-wrapped-pointer-type foo
foo?
wrap-foo unwrap-foo
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.0-108-gbb455e4,
Andy Wingo <=