From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Andreas Rottmann Newsgroups: gmane.lisp.guile.devel Subject: [PATCH] Several tweaks for R6RS ports Date: Sun, 06 Mar 2011 17:38:25 +0100 Message-ID: <87aah8qk5a.fsf@gmx.at> NNTP-Posting-Host: lo.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: dough.gmane.org 1299429534 19560 80.91.229.12 (6 Mar 2011 16:38:54 GMT) X-Complaints-To: usenet@dough.gmane.org NNTP-Posting-Date: Sun, 6 Mar 2011 16:38:54 +0000 (UTC) To: Guile Development Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Sun Mar 06 17:38:50 2011 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([199.232.76.165]) by lo.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1PwGyn-0008Kz-LK for guile-devel@m.gmane.org; Sun, 06 Mar 2011 17:38:50 +0100 Original-Received: from localhost ([127.0.0.1]:53175 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1PwGyn-0007ji-5W for guile-devel@m.gmane.org; Sun, 06 Mar 2011 11:38:49 -0500 Original-Received: from [140.186.70.92] (port=55391 helo=eggs.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1PwGyi-0007fJ-Cp for guile-devel@gnu.org; Sun, 06 Mar 2011 11:38:46 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1PwGyf-0004s9-0J for guile-devel@gnu.org; Sun, 06 Mar 2011 11:38:43 -0500 Original-Received: from mailout-de.gmx.net ([213.165.64.23]:43097) by eggs.gnu.org with smtp (Exim 4.71) (envelope-from ) id 1PwGye-0004pu-D7 for guile-devel@gnu.org; Sun, 06 Mar 2011 11:38:40 -0500 Original-Received: (qmail invoked by alias); 06 Mar 2011 16:38:37 -0000 Original-Received: from 83-215-154-5.hage.dyn.salzburg-online.at (EHLO nathot.lan) [83.215.154.5] by mail.gmx.net (mp055) with SMTP; 06 Mar 2011 17:38:37 +0100 X-Authenticated: #3102804 X-Provags-ID: V01U2FsdGVkX182RuJokC82AgQkxRKjW+wo6LT7cdOqwhYi0VB3nT IVW6/s0+Z/rY9x Original-Received: from localhost (localhost.localdomain [127.0.0.1]) by nathot.lan (Postfix) with ESMTP id C9DB43A68F for ; Sun, 6 Mar 2011 17:38:36 +0100 (CET) Original-Received: from nathot.lan ([127.0.0.1]) by localhost (nathot.lan [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id BKv1anBP4x-w for ; Sun, 6 Mar 2011 17:38:26 +0100 (CET) Original-Received: from delenn.lan (delenn.lan [192.168.3.11]) by nathot.lan (Postfix) with ESMTP id 6CF203A685 for ; Sun, 6 Mar 2011 17:38:26 +0100 (CET) Original-Received: by delenn.lan (Postfix, from userid 1000) id 193502C00C8; Sun, 6 Mar 2011 17:38:26 +0100 (CET) User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/24.0.50 (gnu/linux) X-Y-GMX-Trusted: 0 X-detected-operating-system: by eggs.gnu.org: Genre and OS details not recognized. X-Received-From: 213.165.64.23 X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.5 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:11789 Archived-At: --=-=-= Content-Type: text/plain Hi! Here's a few patches related to R6RS port support, in short: - Add missing `get-string-n!' and `get-string-n' - Fix a few missing exports - A bit of work on transcoder-related stuff See the patch headers for details. The patches are attached in the order they should be applied, although "get-string-n.diff" and the other two have been developed independently, so applying them in this order will result in offsets and fuzzyness for the later patches. If there are issues with that, apply either "get-string-n" or both of "rnrs-io-current-ports" and "rnrs-transcoders", and come back to me, so I can regenerate the remaining patches to make them apply cleanly. --=-=-= Content-Type: text/x-diff; charset=utf-8 Content-Disposition: attachment; filename=get-string-n.diff Content-Transfer-Encoding: quoted-printable From: Andreas Rottmann Subject: Add `get-string-n' and `get-string-n!' for R6RS ports * libguile/r6rs-ports.c (scm_get_string_n_x): Implement `get-string-n!' in C for efficiency. * libguile/r6rs-ports.h: Add prototype for this function. * module/ice-9/binary-ports.scm: Export `get-string-n!'. * module/rnrs/io/ports.scm (get-string-n): Implement based on `get-string-n!'. Export both `get-string-n!' and `get-string-n'. * module/rnrs.scm: Also export these. * test-suite/tests/r6rs-ports.test (8.2.9 Textual input): Add a few tests for `get-string-n' and `get-string-n!'. --- libguile/r6rs-ports.c | 42 ++++++++++++++++++++++++++++++++++= +++- libguile/r6rs-ports.h | 3 +- module/ice-9/binary-ports.scm | 1 + module/rnrs.scm | 3 +- module/rnrs/io/ports.scm | 16 ++++++++++++- test-suite/tests/r6rs-ports.test | 18 ++++++++++++++++ 6 files changed, 78 insertions(+), 5 deletions(-) diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index 8058ca0..1f72415 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2009, 2010 Free Software Foundation, Inc. +/* Copyright (C) 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 @@ -1222,6 +1222,46 @@ SCM_DEFINE (scm_i_make_transcoded_port, #undef FUNC_NAME =20 +/* Textual I/O */ + +SCM_DEFINE (scm_get_string_n_x, + "get-string-n!", 4, 0, 0, + (SCM port, SCM str, SCM start, SCM count), + "Read up to @var{count} characters from @var{port} into " + "@var{str}, starting at @var{start}. If no characters " + "can be read before the end of file is encountered, the end " + "of file object is returned. Otherwise, the number of " + "characters read is returned.") +#define FUNC_NAME s_scm_get_string_n_x +{ + size_t c_start, c_count, c_len, c_end, j; + scm_t_wchar c; + + SCM_VALIDATE_OPINPORT (1, port); + SCM_VALIDATE_STRING (2, str); + c_len =3D scm_c_string_length (str); + c_start =3D scm_to_size_t (start); + c_count =3D scm_to_size_t (count); + c_end =3D c_start + c_count; + + if (SCM_UNLIKELY (c_end > c_len)) + scm_out_of_range (FUNC_NAME, count); + + for (j =3D c_start; j < c_end; j++) + { + c =3D scm_getc (port); + if (c =3D=3D EOF) + { + size_t chars_read =3D j - c_start; + return chars_read =3D=3D 0 ? SCM_EOF_VAL : scm_from_size_t (char= s_read); + } + scm_c_string_set_x (str, j, SCM_MAKE_CHAR (c)); + } + return count; +} +#undef FUNC_NAME + + /* Initialization. */ =20 void diff --git a/libguile/r6rs-ports.h b/libguile/r6rs-ports.h index edde005..2ae3e76 100644 --- a/libguile/r6rs-ports.h +++ b/libguile/r6rs-ports.h @@ -1,7 +1,7 @@ #ifndef SCM_R6RS_PORTS_H #define SCM_R6RS_PORTS_H =20 -/* Copyright (C) 2009, 2010 Free Software Foundation, Inc. +/* Copyright (C) 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 @@ -38,6 +38,7 @@ SCM_API SCM scm_put_u8 (SCM, SCM); SCM_API SCM scm_put_bytevector (SCM, SCM, SCM, SCM); SCM_API SCM scm_open_bytevector_output_port (SCM); SCM_API SCM scm_make_custom_binary_output_port (SCM, SCM, SCM, SCM, SCM); +SCM_API SCM scm_get_string_n_x (SCM, SCM, SCM, SCM); =20 SCM_API void scm_init_r6rs_ports (void); SCM_INTERNAL void scm_register_r6rs_ports (void); diff --git a/module/ice-9/binary-ports.scm b/module/ice-9/binary-ports.scm index 63d09cf..c07900b 100644 --- a/module/ice-9/binary-ports.scm +++ b/module/ice-9/binary-ports.scm @@ -37,6 +37,7 @@ get-bytevector-n! get-bytevector-some get-bytevector-all + get-string-n! put-u8 put-bytevector open-bytevector-output-port diff --git a/module/rnrs.scm b/module/rnrs.scm index 476a3ab..77090d0 100644 --- a/module/rnrs.scm +++ b/module/rnrs.scm @@ -182,7 +182,8 @@ make-custom-textual-output-port call-with-string-output-port flush-output-port put-string - get-char get-datum get-line get-string-all lookahead-char + get-char get-datum get-line get-string-all get-string-n get-stri= ng-n! + lookahead-char put-char put-datum put-string standard-input-port standard-output-port standard-error-port =20=20=20=20=20=20=20=20=20=20=20 diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm index d3a81b7..d3b16ac 100644 --- a/module/rnrs/io/ports.scm +++ b/module/rnrs/io/ports.scm @@ -68,8 +68,9 @@ put-u8 put-bytevector =20 ;; textual input - get-char get-datum get-line get-string-all lookahead-char -=20=20=20=20=20=20=20=20=20=20=20 + get-char get-datum get-line get-string-all get-string-n get-stri= ng-n! + lookahead-char + ;; textual output put-char put-datum put-string =20 @@ -386,6 +387,17 @@ return the characters accumulated in that port." (define (get-string-all port) (with-i/o-decoding-error (read-delimited "" port 'concat))) =20 +(define (get-string-n port count) + "Read up to @var{count} characters from @var{port}. +If no characters could be read before encountering the end of file, +return the end-of-file object, otherwise return a string containing +the characters read." + (let* ((s (make-string count)) + (rv (get-string-n! port s 0 count))) + (cond ((eof-object? rv) rv) + ((=3D rv count) s) + (else (substring/shared s 0 rv))))) + (define (lookahead-char port) (with-i/o-decoding-error (peek-char port))) =20 diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports= .test index df056a4..fe2197f 100644 --- a/test-suite/tests/r6rs-ports.test +++ b/test-suite/tests/r6rs-ports.test @@ -567,6 +567,24 @@ (put-string tp "The letter =CE=BB cannot be represented in Latin= -1.") #f))))) =20 +(with-test-prefix "8.2.9 Textual input" +=20=20 + (pass-if "get-string-n [short]" + (let ((port (open-input-string "GNU Guile"))) + (string=3D? "GNU " (get-string-n port 4)))) + (pass-if "get-string-n [long]" + (let ((port (open-input-string "GNU Guile"))) + (string=3D? "GNU Guile" (get-string-n port 256)))) + (pass-if "get-string-n [eof]" + (let ((port (open-input-string ""))) + (eof-object? (get-string-n port 4)))) + + (pass-if "get-string-n! [short]" + (let ((port (open-input-string "GNU Guile")) + (s (string-copy "Isn't XXX great?"))) + (and (=3D 3 (get-string-n! port s 6 3)) + (string=3D? s "Isn't GNU great?"))))) + ;;; Local Variables: ;;; mode: scheme ;;; eval: (put 'guard 'scheme-indent-function 1) --=20 tg: (d59dd06..) t/get-string-n (depends on: stable-2.0) --=-=-= Content-Type: text/x-diff Content-Disposition: attachment; filename=rnrs-io-current-ports.diff From: Andreas Rottmann Subject: Export `current-*-port' from `(rnrs io ports)' * module/rnrs/io/ports.scm: Export `current-input-port', `current-output-port' and `current-error-port' (see R6RS 8.2.7 "Input ports" and 8.2.10 "Output ports"). --- module/rnrs/io/ports.scm | 1 + 1 files changed, 1 insertions(+), 0 deletions(-) diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm index d3a81b7..b98811a 100644 --- a/module/rnrs/io/ports.scm +++ b/module/rnrs/io/ports.scm @@ -75,6 +75,7 @@ ;; standard ports standard-input-port standard-output-port standard-error-port + current-input-port current-output-port current-error-port ;; condition types &i/o i/o-error? make-i/o-error -- tg: (d59dd06..) t/rnrs-io-current-ports (depends on: stable-2.0) --=-=-= Content-Type: text/x-diff; charset=utf-8 Content-Disposition: attachment; filename=rnrs-transcoders.diff Content-Transfer-Encoding: quoted-printable From: Andreas Rottmann Subject: Enhance transcoder-related functionality of `(rnrs io ports)' * module/rnrs/io/ports.scm (transcoder-eol-style) (transcoder-error-handling-mode): Export these. * module/rnrs.scm: Ditto here. * module/rnrs/io/ports.scm (port-transcoder): Implement this procedure. (binary-port?): Treat only ports without an encoding as binary ports,=20 add docstring. (textual-port?): Implement this procedure. (standard-input-port, standard-output-port, standard-error-port): Ensure = these=20 are created without an encoding. (eol-style): Add `none' as enumeration member. (native-eol-style): Switch to `none' from `lf'. * test-suite/tests/r6rs-ports.test (7.2.7 Input ports) (8.2.10 Output ports): Test binary-ness of `standard-input-port', `standard-output-port' and `standard-error-port'. (8.2.6 Input and output ports): Add test for `port-transcoder'. --- module/rnrs.scm | 3 +- module/rnrs/io/ports.scm | 42 +++++++++++++++++++++++++++++-----= --- test-suite/tests/r6rs-ports.test | 32 ++++++++++++++++++++++++++-- 3 files changed, 64 insertions(+), 13 deletions(-) diff --git a/module/rnrs.scm b/module/rnrs.scm index 476a3ab..58d9638 100644 --- a/module/rnrs.scm +++ b/module/rnrs.scm @@ -162,7 +162,8 @@ =20 file-options buffer-mode buffer-mode? eol-style native-eol-style error-handling-mode - make-transcoder transcoder-codec native-transcoder + make-transcoder transcoder-codec transcoder-eol-style + transcoder-error-handling-mode native-transcoder latin-1-codec utf-8-codec utf-16-codec =20=09=20=20 eof-object? port? input-port? output-port? eof-object port-eof? diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm index b98811a..097c9d3 100644 --- a/module/rnrs/io/ports.scm +++ b/module/rnrs/io/ports.scm @@ -32,13 +32,14 @@ ;; auxiliary types file-options buffer-mode buffer-mode? eol-style native-eol-style error-handling-mode - make-transcoder transcoder-codec native-transcoder + make-transcoder transcoder-codec transcoder-eol-style + transcoder-error-handling-mode native-transcoder latin-1-codec utf-8-codec utf-16-codec =20=20=20=20=20=20=20=20=20=20=20=20 ;; input & output ports port? input-port? output-port? port-eof? - port-transcoder binary-port? transcoded-port + port-transcoder binary-port? textual-port? transcoded-port port-position set-port-position! port-has-port-position? port-has-set-port-position!? call-with-port close-port @@ -128,11 +129,11 @@ (enum-set-member? symbol (enum-set-universe (buffer-modes)))) =20 (define-enumeration eol-style - (lf cr crlf nel crnel ls) + (lf cr crlf nel crnel ls none) eol-styles) =20 (define (native-eol-style) - (eol-style lf)) + (eol-style none)) =20 (define-enumeration error-handling-mode (ignore raise replace) @@ -189,10 +190,30 @@ ;;; =20 (define (port-transcoder port) - (error "port transcoders are not supported" port)) + "Return the transcoder object associated with @var{port}, or @code{#f} +if the port has no transcoder." + (cond ((port-encoding port) + =3D> (lambda (encoding) + (make-transcoder + encoding + (native-eol-style) + (case (port-conversion-strategy port) + ((error) 'raise) + ((substitute) 'replace) + (else + (assertion-violation 'port-transcoder + "unsupported error handling mode"))= )))) + (else + #f))) =20 (define (binary-port? port) - ;; So far, we don't support transcoders other than the binary transcoder. + "Returns @code{#t} if @var{port} does not have an associated encoding, +@code{#f} otherwise." + (not (port-encoding port))) + +(define (textual-port? port) + "Always returns @var{#t}, as all ports can be used for textual I/O in +Guile." #t) =20 (define (port-eof? port) @@ -396,13 +417,16 @@ return the characters accumulated in that port." ;;; =20 (define (standard-input-port) - (dup->inport 0)) + (with-fluids ((%default-port-encoding #f)) + (dup->inport 0))) =20 (define (standard-output-port) - (dup->outport 1)) + (with-fluids ((%default-port-encoding #f)) + (dup->outport 1))) =20 (define (standard-error-port) - (dup->outport 2)) + (with-fluids ((%default-port-encoding #f)) + (dup->outport 2))) =20 ) =20 diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports= .test index df056a4..d0f5666 100644 --- a/test-suite/tests/r6rs-ports.test +++ b/test-suite/tests/r6rs-ports.test @@ -397,7 +397,11 @@ =20 (close-port port) (gc) ; Test for marking a closed port. - closed?))) + closed?)) + + (pass-if "standard-input-port is binary" + (with-fluids ((%default-port-encoding "UTF-8")) + (binary-port? (standard-input-port))))) =20 (with-test-prefix "8.2.10 Output ports" @@ -509,7 +513,15 @@ (put-bytevector port source) (and (=3D sink-pos (bytevector-length source)) (not eof?) - (bytevector=3D? sink source))))) + (bytevector=3D? sink source)))) + + (pass-if "standard-output-port is binary" + (with-fluids ((%default-port-encoding "UTF-8")) + (binary-port? (standard-output-port)))) + + (pass-if "standard-error-port is binary" + (with-fluids ((%default-port-encoding "UTF-8")) + (binary-port? (standard-error-port))))) =20 (with-test-prefix "8.2.6 Input and output ports" @@ -565,7 +577,21 @@ (char=3D? (i/o-encoding-error-char c) #\=CE=BB) (bytevector=3D? (get) (string->utf8 "The letter ")= )))) (put-string tp "The letter =CE=BB cannot be represented in Latin= -1.") - #f))))) + #f)))) + + (pass-if "port-transcoder [binary port]" + (not (port-transcoder (open-bytevector-input-port #vu8())))) + + (pass-if "port-transcoder [transcoded port]" + (let* ((p (transcoded-port (open-bytevector-input-port (string->utf8 "= foo")) + (make-transcoder (utf-8-codec)))) + (t (port-transcoder p))) + (and t + (transcoder-codec t) + (eq? (native-eol-style) + (transcoder-eol-style t)) + (eq? (error-handling-mode replace) + (transcoder-error-handling-mode t)))))) =20 ;;; Local Variables: ;;; mode: scheme --=20 tg: (9421ef5..) t/rnrs-transcoders (depends on: t/rnrs-io-current-ports) --=-=-= Content-Type: text/plain Regards, Rotty -- Andreas Rottmann -- --=-=-=--