summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/r6rs-ports.c17
-rw-r--r--test-suite/tests/r6rs-ports.test11
2 files changed, 20 insertions, 8 deletions
diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c
index fecc5bd46..790c24cce 100644
--- a/libguile/r6rs-ports.c
+++ b/libguile/r6rs-ports.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 2009, 2010, 2011, 2013, 2014 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
@@ -224,10 +224,14 @@ cbp_seek (SCM port, scm_t_off offset, int whence)
result = scm_call_0 (get_position_proc);
else
scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
- "R6RS custom binary port does not "
- "support `port-position'");
-
- offset += scm_to_int (result);
+ "R6RS custom binary port with "
+ "`port-position' support");
+ c_result = scm_to_int (result);
+ if (offset == 0)
+ /* We just want to know the current position. */
+ break;
+
+ offset += c_result;
/* Fall through. */
}
@@ -240,8 +244,7 @@ cbp_seek (SCM port, scm_t_off offset, int whence)
result = scm_call_1 (set_position_proc, scm_from_int (offset));
else
scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
- "R6RS custom binary port does not "
- "support `set-port-position!'");
+ "seekable R6RS custom binary port");
/* Assuming setting the position succeeded. */
c_result = offset;
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index 2db2c5609..eaae29fdc 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -1,6 +1,6 @@
;;;; r6rs-ports.test --- R6RS I/O port tests. -*- coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012, 2014 Free Software Foundation, Inc.
;;;; Ludovic Courtès
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -411,6 +411,15 @@
(not (or (port-has-port-position? port)
(port-has-set-port-position!? port)))))
+ (pass-if-equal "custom binary input port supports `port-position', \
+not `set-port-position!'"
+ 42
+ (let ((port (make-custom-binary-input-port "the port" (const 0)
+ (const 42) #f #f)))
+ (and (port-has-port-position? port)
+ (not (port-has-set-port-position!? port))
+ (port-position port))))
+
(pass-if "custom binary input port supports `port-position'"
(let* ((str "Hello Port!")
(source (open-bytevector-input-port