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: Re: [PATCH] Several tweaks for R6RS ports Date: Tue, 08 Mar 2011 01:58:22 +0100 Message-ID: <87tyfe2ztd.fsf@gmx.at> References: <87aah8qk5a.fsf@gmx.at> NNTP-Posting-Host: lo.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: dough.gmane.org 1299545923 13125 80.91.229.12 (8 Mar 2011 00:58:43 GMT) X-Complaints-To: usenet@dough.gmane.org NNTP-Posting-Date: Tue, 8 Mar 2011 00:58:43 +0000 (UTC) To: Guile Development Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Tue Mar 08 01:58:39 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 1PwlG2-0007Ba-NT for guile-devel@m.gmane.org; Tue, 08 Mar 2011 01:58:39 +0100 Original-Received: from localhost ([127.0.0.1]:50553 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1PwlG2-0006sK-8x for guile-devel@m.gmane.org; Mon, 07 Mar 2011 19:58:38 -0500 Original-Received: from [140.186.70.92] (port=52844 helo=eggs.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1PwlFy-0006rT-M0 for guile-devel@gnu.org; Mon, 07 Mar 2011 19:58:35 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1PwlFw-0005yV-Uy for guile-devel@gnu.org; Mon, 07 Mar 2011 19:58:34 -0500 Original-Received: from mailout-de.gmx.net ([213.165.64.23]:36546) by eggs.gnu.org with smtp (Exim 4.71) (envelope-from ) id 1PwlFw-0005yF-DT for guile-devel@gnu.org; Mon, 07 Mar 2011 19:58:32 -0500 Original-Received: (qmail invoked by alias); 08 Mar 2011 00:58:30 -0000 Original-Received: from 83-215-154-5.hage.dyn.salzburg-online.at (EHLO nathot.lan) [83.215.154.5] by mail.gmx.net (mp045) with SMTP; 08 Mar 2011 01:58:30 +0100 X-Authenticated: #3102804 X-Provags-ID: V01U2FsdGVkX1/g/d4YDcHg0USxgYqatW5YED0YCWdmI6Qrw18AQG Ng7uGgIlj40mQp Original-Received: from localhost (localhost.localdomain [127.0.0.1]) by nathot.lan (Postfix) with ESMTP id 818403A68F for ; Tue, 8 Mar 2011 01:58:29 +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 QTtBs3i0p1kJ for ; Tue, 8 Mar 2011 01:58:22 +0100 (CET) Original-Received: from delenn.lan (delenn.lan [192.168.3.11]) by nathot.lan (Postfix) with ESMTP id 70A033A685 for ; Tue, 8 Mar 2011 01:58:22 +0100 (CET) Original-Received: by delenn.lan (Postfix, from userid 1000) id 32D9D2C00C8; Tue, 8 Mar 2011 01:58:22 +0100 (CET) In-Reply-To: <87aah8qk5a.fsf@gmx.at> (Andreas Rottmann's message of "Sun, 06 Mar 2011 17:38:25 +0100") 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: GNU/Linux 2.6 (newer, 3) 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:11826 Archived-At: --=-=-= Content-Type: text/plain Andreas Rottmann writes: > 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 > Attached is an updated version of the "rnrs-transcoders" patch; relative to its predecessor, it just adds `textual-port?' to the exports in `(rnrs)' and has a few tweaks to the ChangeLog entries. --=-=-= Content-Type: text/x-diff; charset=utf-8 Content-Disposition: inline; 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. (textual-port?): Implement this procedure and export it. * module/rnrs.scm: Export these here as well. * module/rnrs/io/ports.scm (port-transcoder): Implement this procedure. (binary-port?): Treat only ports without an encoding as binary ports,=20 add docstring. * module/rnrs/io/ports.scm: (standard-input-port, standard-output-port) (standard-error-port): Ensure these 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 | 6 +++- module/rnrs/io/ports.scm | 42 +++++++++++++++++++++++++++++-----= --- test-suite/tests/r6rs-ports.test | 32 ++++++++++++++++++++++++++-- 3 files changed, 66 insertions(+), 14 deletions(-) diff --git a/module/rnrs.scm b/module/rnrs.scm index 476a3ab..6fde880 100644 --- a/module/rnrs.scm +++ b/module/rnrs.scm @@ -162,12 +162,14 @@ =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? port-transcoder - binary-port? transcoded-port port-position set-port-position! + binary-port? textual-port? transcoded-port + port-position set-port-position! port-has-port-position? port-has-set-port-position!? close-port call-with-port open-bytevector-input-port make-custom-binary-input-port get-u8=20 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 -- --=-=-=--