From 6dce942c46494460369b8a93d3c657e1f6e57fed Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 7 Aug 2013 00:46:34 -0400 Subject: String ports use UTF-8; ignore %default-port-encoding. * libguile/strports.c (scm_mkstrport): Use UTF-8; ignore %default-port-encoding. Rename 'str_len' and 'c_pos' to 'num_bytes' and 'c_byte_pos'. Interpret 'pos' argument as a character index instead of a byte index. * module/ice-9/boot-9.scm (%cond-expand-features): Add srfi-6 to the list of core features. * module/srfi/srfi-6.scm (open-input-string, open-output-string): Simply re-export these, since the core versions are now compliant. * doc/ref/api-io.texi (String Ports): Remove text that describes non-compliant behavior of string ports with regard to encoding. * doc/ref/srfi-modules.texi (SRFI-0): Add srfi-6 to the list of core features. (SRFI-6): Remove text that mentions non-compliant behavior of core string ports. * module/ice-9/format.scm (format): * module/ice-9/pretty-print.scm (truncated-print): * module/rnrs/io/ports.scm (open-string-input-port, open-string-output-port): * test-suite/test-suite/lib.scm (format-test-name): * test-suite/tests/chars.test ("combining accent is pretty-printed", "combining X is pretty-printed"): * test-suite/tests/ecmascript.test (eread, eread/1): * test-suite/tests/rdelim.test: * test-suite/tests/reader.test (read-string): * test-suite/tests/regexp.test: * test-suite/tests/srfi-105.test (read-string): Don't set %default-port-encoding before creating string ports. * benchmark-suite/benchmarks/ports.bm (%latin1-port): Use 'set-port-encoding!' to set the string port encoding. (%utf8/ascii-port, %utf8/wide-port, "rdelim"): Don't set %default-port-encoding before creating string ports. * test-suite/tests/r6rs-ports.test ("lookahead-u8 non-ASCII"): Don't set %default-port-encoding before creating string ports. ("put-bytevector with UTF-16 string port", "put-bytevector with wrong-encoding string port"): Use 'set-port-encoding!' to set the string port encoding. * test-suite/tests/print.test (tprint): Use 'set-port-encoding!' to set the string port encoding. ("truncated-print"): Use 'pass-if-equal'. * test-suite/tests/ports.test ("encoding failure leads to exception", "%default-port-encoding is honored", "peek-char [latin-1]", "peek-char [utf-8]", "peek-char [utf-16]"): Remove tests. ("%default-port-encoding is ignored", "peek-char"): Add tests. ("suitable encoding [latin-1]", "suitable encoding [latin-3]", "wrong encoding, error", "wrong encoding, substitute", "wrong encoding, escape"): Use 'set-port-encoding!' to set the string port encoding. ("%default-port-encoding, wrong encoding"): Rewrite to use a file port instead of a string port. --- module/ice-9/pretty-print.scm | 272 +++++++++++++++++++++--------------------- 1 file changed, 134 insertions(+), 138 deletions(-) (limited to 'module/ice-9/pretty-print.scm') diff --git a/module/ice-9/pretty-print.scm b/module/ice-9/pretty-print.scm index 5c23cb009..1573c6fd5 100644 --- a/module/ice-9/pretty-print.scm +++ b/module/ice-9/pretty-print.scm @@ -1,7 +1,7 @@ ;;;; -*- coding: utf-8; mode: scheme -*- ;;;; ;;;; Copyright (C) 2001, 2004, 2006, 2009, 2010, -;;;; 2012 Free Software Foundation, Inc. +;;;; 2012, 2013 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 @@ -311,142 +311,138 @@ e.g., if @var{x} is a vector, each member of @var{x}. One can attempt to \"ration\" the available width, trying to allocate it equally to each sub-expression, via the @var{breadth-first?} keyword argument." - ;; Make sure string ports are created with the right encoding. - (with-fluids ((%default-port-encoding (port-encoding port))) - - (define ellipsis - ;; Choose between `HORIZONTAL ELLIPSIS' (U+2026) and three dots, depending - ;; on the encoding of PORT. - (let ((e "…")) - (catch 'encoding-error - (lambda () - (with-fluids ((%default-port-conversion-strategy 'error)) - (with-output-to-string - (lambda () - (display e))))) - (lambda (key . args) - "...")))) - - (let ((ellipsis-width (string-length ellipsis))) - - (define (print-sequence x width len ref next) - (let lp ((x x) - (width width) - (i 0)) - (if (> i 0) - (display #\space)) - (cond - ((= i len)) ; catches 0-length case - ((and (= i (1- len)) (or (zero? i) (> width 1))) - (print (ref x i) (if (zero? i) width (1- width)))) - ((<= width (+ 1 ellipsis-width)) - (display ellipsis)) - (else - (let ((str - (with-fluids ((%default-port-encoding (port-encoding port))) - (with-output-to-string - (lambda () - (print (ref x i) - (if breadth-first? - (max 1 - (1- (floor (/ width (- len i))))) - (- width (+ 1 ellipsis-width))))))))) - (display str) - (lp (next x) (- width 1 (string-length str)) (1+ i))))))) - - (define (print-tree x width) - ;; width is >= the width of # . #, which is 5 - (let lp ((x x) - (width width)) - (cond - ((or (not (pair? x)) (<= width 4)) - (display ". ") - (print x (- width 2))) - (else - ;; width >= 5 - (let ((str (with-output-to-string - (lambda () - (print (car x) - (if breadth-first? - (floor (/ (- width 3) 2)) - (- width 4))))))) - (display str) - (display " ") - (lp (cdr x) (- width 1 (string-length str)))))))) - - (define (truncate-string str width) - ;; width is < (string-length str) - (let lp ((fixes '(("#<" . ">") - ("#(" . ")") - ("(" . ")") - ("\"" . "\"")))) - (cond - ((null? fixes) - "#") - ((and (string-prefix? (caar fixes) str) - (string-suffix? (cdar fixes) str) - (>= (string-length str) - width - (+ (string-length (caar fixes)) - (string-length (cdar fixes)) - ellipsis-width))) - (format #f "~a~a~a~a" - (caar fixes) - (substring str (string-length (caar fixes)) - (- width (string-length (cdar fixes)) - ellipsis-width)) - ellipsis - (cdar fixes))) - (else - (lp (cdr fixes)))))) - - (define (print x width) + (define ellipsis + ;; Choose between `HORIZONTAL ELLIPSIS' (U+2026) and three dots, depending + ;; on the encoding of PORT. + (let ((e "…")) + (catch 'encoding-error + (lambda () + (with-fluids ((%default-port-conversion-strategy 'error)) + (call-with-output-string + (lambda (p) + (set-port-encoding! p (port-encoding port)) + (display e p))))) + (lambda (key . args) + "...")))) + + (let ((ellipsis-width (string-length ellipsis))) + + (define (print-sequence x width len ref next) + (let lp ((x x) + (width width) + (i 0)) + (if (> i 0) + (display #\space)) (cond - ((<= width 0) - (error "expected a positive width" width)) - ((list? x) - (cond - ((>= width (+ 2 ellipsis-width)) - (display "(") - (print-sequence x (- width 2) (length x) - (lambda (x i) (car x)) cdr) - (display ")")) - (else - (display "#")))) - ((vector? x) - (cond - ((>= width (+ 3 ellipsis-width)) - (display "#(") - (print-sequence x (- width 3) (vector-length x) - vector-ref identity) - (display ")")) - (else - (display "#")))) - ((uniform-vector? x) - (cond - ((>= width 9) - (format #t "#~a(" (uniform-vector-element-type x)) - (print-sequence x (- width 6) (uniform-vector-length x) - uniform-vector-ref identity) - (display ")")) - (else - (display "#")))) - ((pair? x) - (cond - ((>= width (+ 4 ellipsis-width)) - (display "(") - (print-tree x (- width 2)) - (display ")")) - (else - (display "#")))) + ((= i len)) ; catches 0-length case + ((and (= i (1- len)) (or (zero? i) (> width 1))) + (print (ref x i) (if (zero? i) width (1- width)))) + ((<= width (+ 1 ellipsis-width)) + (display ellipsis)) (else - (let* ((str (with-output-to-string - (lambda () (if display? (display x) (write x))))) - (len (string-length str))) - (display (if (<= (string-length str) width) - str - (truncate-string str width))))))) - - (with-output-to-port port - (lambda () - (print x width)))))) + (let ((str (with-output-to-string + (lambda () + (print (ref x i) + (if breadth-first? + (max 1 + (1- (floor (/ width (- len i))))) + (- width (+ 1 ellipsis-width)))))))) + (display str) + (lp (next x) (- width 1 (string-length str)) (1+ i))))))) + + (define (print-tree x width) + ;; width is >= the width of # . #, which is 5 + (let lp ((x x) + (width width)) + (cond + ((or (not (pair? x)) (<= width 4)) + (display ". ") + (print x (- width 2))) + (else + ;; width >= 5 + (let ((str (with-output-to-string + (lambda () + (print (car x) + (if breadth-first? + (floor (/ (- width 3) 2)) + (- width 4))))))) + (display str) + (display " ") + (lp (cdr x) (- width 1 (string-length str)))))))) + + (define (truncate-string str width) + ;; width is < (string-length str) + (let lp ((fixes '(("#<" . ">") + ("#(" . ")") + ("(" . ")") + ("\"" . "\"")))) + (cond + ((null? fixes) + "#") + ((and (string-prefix? (caar fixes) str) + (string-suffix? (cdar fixes) str) + (>= (string-length str) + width + (+ (string-length (caar fixes)) + (string-length (cdar fixes)) + ellipsis-width))) + (format #f "~a~a~a~a" + (caar fixes) + (substring str (string-length (caar fixes)) + (- width (string-length (cdar fixes)) + ellipsis-width)) + ellipsis + (cdar fixes))) + (else + (lp (cdr fixes)))))) + + (define (print x width) + (cond + ((<= width 0) + (error "expected a positive width" width)) + ((list? x) + (cond + ((>= width (+ 2 ellipsis-width)) + (display "(") + (print-sequence x (- width 2) (length x) + (lambda (x i) (car x)) cdr) + (display ")")) + (else + (display "#")))) + ((vector? x) + (cond + ((>= width (+ 3 ellipsis-width)) + (display "#(") + (print-sequence x (- width 3) (vector-length x) + vector-ref identity) + (display ")")) + (else + (display "#")))) + ((uniform-vector? x) + (cond + ((>= width 9) + (format #t "#~a(" (uniform-vector-element-type x)) + (print-sequence x (- width 6) (uniform-vector-length x) + uniform-vector-ref identity) + (display ")")) + (else + (display "#")))) + ((pair? x) + (cond + ((>= width (+ 4 ellipsis-width)) + (display "(") + (print-tree x (- width 2)) + (display ")")) + (else + (display "#")))) + (else + (let* ((str (with-output-to-string + (lambda () (if display? (display x) (write x))))) + (len (string-length str))) + (display (if (<= (string-length str) width) + str + (truncate-string str width))))))) + + (with-output-to-port port + (lambda () + (print x width))))) -- cgit v1.2.1