mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 03:30:27 +02:00
Code Activity

'port-position' works on CBIPs that do not support 'set-port-position!'.

Browse source 
* libguile/r6rs-ports.c (cbp_seek)[WHENCE == SEEK_CUR]: Break out of the
  switch statement when OFFSET is zero.
  Pass 'scm_wrong_type_arg_msg' a phrase suitable for use after
  "expecting".
* test-suite/tests/r6rs-ports.test ("7.2.7 Input Ports")["custom binary
  input port supports `port-position', not `set-port-position!'"]: New
  test.
This commit is contained in:
Ludovic Courtès 2014-01-13 23:15:28 +01:00
parent 7af706e36e
commit c9d55a7e4e
2 changed files with 19 additions and 7 deletions
Download patch file Download diff file Expand all files Collapse all files

15
libguile/r6rs-ports.c
View file

@ -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'");
"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 += scm_to_int (result);
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;

11
test-suite/tests/r6rs-ports.test
View file

@ -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