[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-6-104-ga5
|
From: |
Ludovic Courtès |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-6-104-ga589525 |
|
Date: |
Fri, 08 Jan 2010 20:52:13 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=a589525d4e1d0e4ce385a01820a7fa6fa9a5030e
The branch, master has been updated
via a589525d4e1d0e4ce385a01820a7fa6fa9a5030e (commit)
via 795ab688ee994181d92c2a106fc2408d86dbbbf8 (commit)
via c5e05a1c70d7a3db2456677524872a590624285f (commit)
from cc7005bc371ee104c368dbb894eb4f8b7a86d64a (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit a589525d4e1d0e4ce385a01820a7fa6fa9a5030e
Author: Ludovic Courtès <address@hidden>
Date: Fri Jan 8 16:12:12 2010 +0100
Fix frame printing in the debugger.
* module/system/vm/debug.scm (location-string): New procedure.
(print-frames): Use it. This fixes cases where LINE is #f and makes a
distinction between FILE = stdin and FILE is unknown.
commit 795ab688ee994181d92c2a106fc2408d86dbbbf8
Author: Ludovic Courtès <address@hidden>
Date: Fri Jan 8 12:02:00 2010 +0100
Factorize the location stack handling in warning analyses.
* module/language/tree-il/analyze.scm (analyze-tree)[traverse]: New
argument UPDATE-LOCS. Update users.
[keep-locs, extend-locs, shrink-locs]: New procedures.
(<binding-info>, <toplevel-info>): Remove `locs' field.
(unused-variable-analysis, unbound-variable-analysis): Update
accordingly.
commit c5e05a1c70d7a3db2456677524872a590624285f
Author: Ludovic Courtès <address@hidden>
Date: Fri Jan 8 10:57:32 2010 +0100
Use `HORIZONTAL ELLIPSIS' when available in `truncated-print'.
* module/ice-9/pretty-print.scm (truncated-print): Set
`%default-port-encoding' to the encoding of PORT. Choose either
U+2026 or "..." depending on PORT's encoding.
* test-suite/tests/print.test ("truncated-print")[tprint]: New ENCODING
argument. Update existing tests accordingly. Add UTF-8 tests.
* doc/ref/misc-modules.texi (Pretty Printing): Mention the possible use
of U+2026.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/misc-modules.texi | 8 +-
module/ice-9/pretty-print.scm | 260 +++++++++++++++++++----------------
module/language/tree-il/analyze.scm | 150 ++++++++++-----------
module/system/vm/debug.scm | 19 ++-
test-suite/tests/print.test | 58 +++++----
5 files changed, 265 insertions(+), 230 deletions(-)
diff --git a/doc/ref/misc-modules.texi b/doc/ref/misc-modules.texi
index 3a361b6..50a478f 100644
--- a/doc/ref/misc-modules.texi
+++ b/doc/ref/misc-modules.texi
@@ -83,9 +83,11 @@ line in which to do so.
@print{} #<directory (gui...>
@end lisp
address@hidden will not output a trailing newline. If an
-expression does not fit in the given width, it will be truncated --
-possibly ellipsized, or in the worst case, displayed as @nicode{#}.
address@hidden will not output a trailing newline. If an expression does
+not fit in the given width, it will be truncated -- possibly
address@hidden Unicode-capable ports, the ellipsis is represented by
+character `HORIZONTAL ELLIPSIS' (U+2026), otherwise it is represented by three
+dots.}, or in the worst case, displayed as @nicode{#}.
@deffn {Scheme Procedure} truncated-print obj [port] [keyword-options]
Print @var{obj}, truncating the output, if necessary, to make it fit
diff --git a/module/ice-9/pretty-print.scm b/module/ice-9/pretty-print.scm
index 9a0edbd..d3e3eca 100644
--- a/module/ice-9/pretty-print.scm
+++ b/module/ice-9/pretty-print.scm
@@ -1,6 +1,6 @@
-;;;; -*-scheme-*-
+;;;; -*- coding: utf-8; mode: scheme -*-
;;;;
-;;;; Copyright (C) 2001, 2004, 2006, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2004, 2006, 2009, 2010 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
@@ -271,6 +271,7 @@ port directly after OBJ, like (pretty-print OBJ PORT)."
per-line-prefix
(lambda (s) (display s port) #t)))
+
;; `truncated-print' was written in 2009 by Andy Wingo, and is not from
;; genwrite.scm.
(define* (truncated-print x #:optional port*
@@ -285,123 +286,146 @@ into @var{width} characters. By default, @var{x} will
be printed using
@var{display?} keyword argument.
The default behaviour is to print depth-first, meaning that the entire
-remaining width will be available to each sub-expressoin of @var{x} --
+remaining width will be available to each sub-expression of @var{x} --
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."
- (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
- ((= i (1- len))
- (print (ref x i) (if (zero? i) width (1- width))))
- ((<= width 4)
- (display "..."))
- (else
- (let ((str (with-output-to-string
- (lambda ()
- (print (ref x i)
- (if breadth-first?
- (max 1
- (1- (floor (/ width (- len i)))))
- (- width 4)))))))
- (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))
- 3)))
- (format #f "~a~a...~a"
- (caar fixes)
- (substring str (string-length (caar fixes))
- (- width (string-length (cdar fixes)) 3))
- (cdar fixes)))
- (else
- (lp (cdr fixes))))))
-
- (define (print x width)
- (cond
- ((<= width 0)
- (error "expected a positive width" width))
- ((list? x)
- (cond
- ((>= width 5)
- (display "(")
- (print-sequence x (- width 2) (length x) (lambda (x i) (car x)) cdr)
- (display ")"))
- (else
- (display "#"))))
- ((vector? x)
- (cond
- ((>= width 6)
- (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 7)
- (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))))
+ ;; 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-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
+ ((= i (1- len))
+ (print (ref x i) (if (zero? i) width (1- width))))
+ ((<= width (+ 1 ellipsis-width))
+ (display "..."))
+ (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)
+ (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))))))
diff --git a/module/language/tree-il/analyze.scm
b/module/language/tree-il/analyze.scm
index b81a7da..abda760 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -1,6 +1,6 @@
;;; TREE-IL -> GLIL compiler
-;; Copyright (C) 2001,2008,2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001,2008,2009,2010 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
@@ -492,33 +492,47 @@
(define-record-type <tree-analysis>
(make-tree-analysis leaf down up post init)
tree-analysis?
- (leaf tree-analysis-leaf) ;; (lambda (x result env) ...)
- (down tree-analysis-down) ;; (lambda (x result env) ...)
- (up tree-analysis-up) ;; (lambda (x result env) ...)
+ (leaf tree-analysis-leaf) ;; (lambda (x result env locs) ...)
+ (down tree-analysis-down) ;; (lambda (x result env locs) ...)
+ (up tree-analysis-up) ;; (lambda (x result env locs) ...)
(post tree-analysis-post) ;; (lambda (result env) ...)
(init tree-analysis-init)) ;; arbitrary value
(define (analyze-tree analyses tree env)
"Run all tree analyses listed in ANALYSES on TREE for ENV, using
-`tree-il-fold'. Return TREE."
- (define (traverse proc)
+`tree-il-fold'. Return TREE. The leaf/down/up procedures of each analysis are
+passed a ``location stack', which is the stack of `tree-il-src' values for each
+parent tree (a list); it can be used to approximate source location when
+accurate information is missing from a given `tree-il' element."
+
+ (define (traverse proc update-locs)
+ ;; Return a tree traversing procedure that returns a list of analysis
+ ;; results prepended by the location stack.
(lambda (x results)
- (map (lambda (analysis result)
- ((proc analysis) x result env))
- analyses
- results)))
+ (let ((locs (update-locs x (car results))))
+ (cons locs ;; the location stack
+ (map (lambda (analysis result)
+ ((proc analysis) x result env locs))
+ analyses
+ (cdr results))))))
+
+ ;; Keeping/extending/shrinking the location stack.
+ (define (keep-locs x locs) locs)
+ (define (extend-locs x locs) (cons (tree-il-src x) locs))
+ (define (shrink-locs x locs) (cdr locs))
(let ((results
- (tree-il-fold (traverse tree-analysis-leaf)
- (traverse tree-analysis-down)
- (traverse tree-analysis-up)
- (map tree-analysis-init analyses)
+ (tree-il-fold (traverse tree-analysis-leaf keep-locs)
+ (traverse tree-analysis-down extend-locs)
+ (traverse tree-analysis-up shrink-locs)
+ (cons '() ;; empty location stack
+ (map tree-analysis-init analyses))
tree)))
(for-each (lambda (analysis result)
((tree-analysis-post analysis) result env))
analyses
- results))
+ (cdr results)))
tree)
@@ -528,35 +542,31 @@
;;;
;; <binding-info> records are used during tree traversals in
-;; `report-unused-variables'. They contain a list of the local vars
-;; currently in scope, a list of locals vars that have been referenced, and a
-;; "location stack" (the stack of `tree-il-src' values for each parent tree).
+;; `unused-variable-analysis'. They contain a list of the local vars
+;; currently in scope, and a list of locals vars that have been referenced.
(define-record-type <binding-info>
- (make-binding-info vars refs locs)
+ (make-binding-info vars refs)
binding-info?
(vars binding-info-vars) ;; ((GENSYM NAME LOCATION) ...)
- (refs binding-info-refs) ;; (GENSYM ...)
- (locs binding-info-locs)) ;; (LOCATION ...)
+ (refs binding-info-refs)) ;; (GENSYM ...)
(define unused-variable-analysis
;; Report unused variables in the given tree.
(make-tree-analysis
- (lambda (x info env)
+ (lambda (x info env locs)
;; X is a leaf: extend INFO's refs accordingly.
(let ((refs (binding-info-refs info))
- (vars (binding-info-vars info))
- (locs (binding-info-locs info)))
+ (vars (binding-info-vars info)))
(record-case x
((<lexical-ref> gensym)
- (make-binding-info vars (cons gensym refs) locs))
+ (make-binding-info vars (cons gensym refs)))
(else info))))
- (lambda (x info env)
+ (lambda (x info env locs)
;; Going down into X: extend INFO's variable list
;; accordingly.
(let ((refs (binding-info-refs info))
(vars (binding-info-vars info))
- (locs (binding-info-locs info))
(src (tree-il-src x)))
(define (extend inner-vars inner-names)
(append (map (lambda (var name)
@@ -566,32 +576,26 @@
vars))
(record-case x
((<lexical-set> gensym)
- (make-binding-info vars (cons gensym refs)
- (cons src locs)))
+ (make-binding-info vars (cons gensym refs)))
((<lambda-case> req opt inits rest kw vars)
(let ((names `(,@req
,@(or opt '())
,@(if rest (list rest) '())
,@(if kw (map cadr (cdr kw)) '()))))
- (make-binding-info (extend vars names) refs
- (cons src locs))))
+ (make-binding-info (extend vars names) refs)))
((<let> vars names)
- (make-binding-info (extend vars names) refs
- (cons src locs)))
+ (make-binding-info (extend vars names) refs))
((<letrec> vars names)
- (make-binding-info (extend vars names) refs
- (cons src locs)))
+ (make-binding-info (extend vars names) refs))
((<fix> vars names)
- (make-binding-info (extend vars names) refs
- (cons src locs)))
+ (make-binding-info (extend vars names) refs))
(else info))))
- (lambda (x info env)
+ (lambda (x info env locs)
;; Leaving X's scope: shrink INFO's variable list
;; accordingly and reported unused nested variables.
(let ((refs (binding-info-refs info))
- (vars (binding-info-vars info))
- (locs (binding-info-locs info)))
+ (vars (binding-info-vars info)))
(define (shrink inner-vars refs)
(for-each (lambda (var)
(let ((gensym (car var)))
@@ -619,21 +623,17 @@
;; makes REFS unnecessarily fat.
(record-case x
((<lambda-case> vars)
- (make-binding-info (shrink vars refs) refs
- (cdr locs)))
+ (make-binding-info (shrink vars refs) refs))
((<let> vars)
- (make-binding-info (shrink vars refs) refs
- (cdr locs)))
+ (make-binding-info (shrink vars refs) refs))
((<letrec> vars)
- (make-binding-info (shrink vars refs) refs
- (cdr locs)))
+ (make-binding-info (shrink vars refs) refs))
((<fix> vars)
- (make-binding-info (shrink vars refs) refs
- (cdr locs)))
+ (make-binding-info (shrink vars refs) refs))
(else info))))
(lambda (result env) #t)
- (make-binding-info '() '() '())))
+ (make-binding-info '() '())))
;;;
@@ -642,14 +642,13 @@
;; <toplevel-info> records are used during tree traversal in search of
;; possibly unbound variable. They contain a list of references to
-;; potentially unbound top-level variables, a list of the top-level defines
-;; that have been encountered, and a "location stack" (see above).
+;; potentially unbound top-level variables, and a list of the top-level
+;; defines that have been encountered.
(define-record-type <toplevel-info>
- (make-toplevel-info refs defs locs)
+ (make-toplevel-info refs defs)
toplevel-info?
(refs toplevel-info-refs) ;; ((VARIABLE-NAME . LOCATION) ...)
- (defs toplevel-info-defs) ;; (VARIABLE-NAME ...)
- (locs toplevel-info-locs)) ;; (LOCATION ...)
+ (defs toplevel-info-defs)) ;; (VARIABLE-NAME ...)
(define (goops-toplevel-definition proc args env)
;; If application of PROC to ARGS is a GOOPS top-level definition, return
@@ -679,11 +678,10 @@
(define unbound-variable-analysis
;; Report possibly unbound variables in the given tree.
(make-tree-analysis
- (lambda (x info env)
+ (lambda (x info env locs)
;; X is a leaf: extend INFO's refs accordingly.
(let ((refs (toplevel-info-refs info))
- (defs (toplevel-info-defs info))
- (locs (toplevel-info-locs info)))
+ (defs (toplevel-info-defs info)))
(define (bound? name)
(or (and (module? env)
(module-variable env name))
@@ -695,16 +693,14 @@
info
(let ((src (or src (find pair? locs))))
(make-toplevel-info (alist-cons name src refs)
- defs
- locs))))
+ defs))))
(else info))))
- (lambda (x info env)
+ (lambda (x info env locs)
;; Going down into X.
(let* ((refs (toplevel-info-refs info))
(defs (toplevel-info-defs info))
- (src (tree-il-src x))
- (locs (cons src (toplevel-info-locs info))))
+ (src (tree-il-src x)))
(define (bound? name)
(or (and (module? env)
(module-variable env name))
@@ -713,15 +709,13 @@
(record-case x
((<toplevel-set> name src)
(if (bound? name)
- (make-toplevel-info refs defs locs)
+ (make-toplevel-info refs defs)
(let ((src (find pair? locs)))
(make-toplevel-info (alist-cons name src refs)
- defs
- locs))))
+ defs))))
((<toplevel-define> name)
(make-toplevel-info (alist-delete name refs eq?)
- (cons name defs)
- locs))
+ (cons name defs)))
((<application> proc args)
;; Check for a dynamic top-level definition, as is
@@ -731,18 +725,16 @@
(if (symbol? name)
(make-toplevel-info (alist-delete name refs
eq?)
- (cons name defs)
- locs)
- (make-toplevel-info refs defs locs))))
+ (cons name defs))
+ (make-toplevel-info refs defs))))
(else
- (make-toplevel-info refs defs locs)))))
+ (make-toplevel-info refs defs)))))
- (lambda (x info env)
+ (lambda (x info env locs)
;; Leaving X's scope.
(let ((refs (toplevel-info-refs info))
- (defs (toplevel-info-defs info))
- (locs (toplevel-info-locs info)))
- (make-toplevel-info refs defs (cdr locs))))
+ (defs (toplevel-info-defs info)))
+ (make-toplevel-info refs defs)))
(lambda (toplevel env)
;; Post-process the result.
@@ -752,7 +744,7 @@
(warning 'unbound-variable loc name)))
(reverse (toplevel-info-refs toplevel))))
- (make-toplevel-info '() '() '())))
+ (make-toplevel-info '() '())))
;;;
@@ -860,10 +852,10 @@
(define arity-analysis
;; Report arity mismatches in the given tree.
(make-tree-analysis
- (lambda (x info env)
+ (lambda (x info env locs)
;; X is a leaf.
info)
- (lambda (x info env)
+ (lambda (x info env locs)
;; Down into X.
(define (extend lexical-name val info)
;; If VAL is a lambda, add NAME to the lexical-lambdas of INFO.
@@ -947,7 +939,7 @@
(else info)))
(else info))))
- (lambda (x info env)
+ (lambda (x info env locs)
;; Up from X.
(define (shrink name val info)
;; Remove NAME from the lexical-lambdas of INFO.
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index e9f30f5..1b8afe2 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -1,6 +1,6 @@
;;; Guile VM debugging facilities
-;;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009, 2010 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
@@ -109,6 +109,13 @@
out
(lp (frame-previous frame) (cons frame out) (1- count)))))))
+(define (location-string file line)
+ (cond ((and file line)
+ (format #f "~:[~5_~;~5d~]" file line))
+ (file
+ (format #f "~:[~5_~" file))
+ (else "<unknown-location>")))
+
(define* (print-frames frames #:optional (port (current-output-port))
#:key (start-index (1- (length frames))) (width 72)
(full? #f))
@@ -116,12 +123,14 @@
(if (pair? frames)
(let* ((frame (car frames))
(source (frame-source frame))
- (file (and=> source source:file))
- (line (and=> source source:line)))
+ (file (and source
+ (or (source:file source) "<stdin>")))
+ (line (and=> source source:line))
+ (loc (location-string file line)))
(if (not (equal? file last-file))
(format port "~&In ~a:~&" (or file "current input")))
- (format port "~:[~5_~;~5d~]:~3d ~v:@y~%" line line i
- width (frame-call-representation frame))
+ (format port "~a:~3d ~v:@y~%"
+ loc i width (frame-call-representation frame))
(if full?
(print-locals frame #:width width
#:per-line-prefix " "))
diff --git a/test-suite/tests/print.test b/test-suite/tests/print.test
index 730de0d..f8c9edc 100644
--- a/test-suite/tests/print.test
+++ b/test-suite/tests/print.test
@@ -1,4 +1,4 @@
-;;;; -*- scheme -*-
+;;;; -*- coding: utf-8; mode: scheme; -*-
;;;;
;;;; Copyright (C) 2010 Free Software Foundation, Inc.
;;;;
@@ -6,12 +6,12 @@
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
-;;;;
+;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
-;;;;
+;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
@@ -22,25 +22,33 @@
(with-test-prefix "truncated-print"
(define exp '(a b #(c d e) f . g))
- (define (tprint x width)
- (with-output-to-string
- (lambda ()
- (truncated-print x #:width width))))
-
- (pass-if (equal? (tprint exp 10)
- "(a b . #)"))
-
- (pass-if (equal? (tprint exp 15)
- "(a b # f . g)"))
-
- (pass-if (equal? (tprint exp 18)
- "(a b #(c ...) . #)"))
-
- (pass-if (equal? (tprint exp 20)
- "(a b #(c d e) f . g)"))
-
- (pass-if (equal? (tprint "The quick brown fox" 20)
- "\"The quick brown...\""))
-
- (pass-if (equal? (tprint (current-module) 20)
- "#<directory (tes...>")))
+
+ (define (tprint x width encoding)
+ (with-fluids ((%default-port-encoding encoding))
+ (with-output-to-string
+ (lambda ()
+ (truncated-print x #:width width)))))
+
+ (pass-if (equal? (tprint exp 10 "ISO-8859-1")
+ "(a b . #)"))
+
+ (pass-if (equal? (tprint exp 15 "ISO-8859-1")
+ "(a b # f . g)"))
+
+ (pass-if (equal? (tprint exp 18 "ISO-8859-1")
+ "(a b #(c ...) . #)"))
+
+ (pass-if (equal? (tprint exp 20 "ISO-8859-1")
+ "(a b #(c d e) f . g)"))
+
+ (pass-if (equal? (tprint "The quick brown fox" 20 "ISO-8859-1")
+ "\"The quick brown...\""))
+
+ (pass-if (equal? (tprint "The quick brown fox" 20 "UTF-8")
+ "\"The quick brown fâ¦\""))
+
+ (pass-if (equal? (tprint (current-module) 20 "ISO-8859-1")
+ "#<directory (tes...>"))
+
+ (pass-if (equal? (tprint (current-module) 20 "UTF-8")
+ "#<directory (test-â¦>")))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-6-104-ga589525,
Ludovic Courtès <=