/[guile]/guile/guile-core/ice-9/pretty-print.scm
ViewVC logotype

Diff of /guile/guile-core/ice-9/pretty-print.scm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.5 by mdj, Sun Oct 21 09:47:25 2001 UTC revision 1.6 by mvo, Sat Jan 12 17:47:44 2002 UTC
# Line 42  Line 42 
42  ;;;; If you do not wish that, delete this exception notice.  ;;;; If you do not wish that, delete this exception notice.
43  ;;;;  ;;;;
44  (define-module (ice-9 pretty-print)  (define-module (ice-9 pretty-print)
45      :use-module (ice-9 optargs)
46    :export (pretty-print))    :export (pretty-print))
47    
48  ;; From SLIB.  ;; From SLIB.
# Line 53  Line 54 
54    
55  (define genwrite:newline-str (make-string 1 #\newline))  (define genwrite:newline-str (make-string 1 #\newline))
56    
57  (define (generic-write obj display? width output)  (define (generic-write obj display? width per-line-prefix output)
58    
59    (define (read-macro? l)    (define (read-macro? l)
60      (define (length1? l) (and (pair? l) (null? (cdr l))))      (define (length1? l) (and (pair? l) (null? (cdr l))))
# Line 137  Line 138 
138      (define (indent to col)      (define (indent to col)
139        (and col        (and col
140             (if (< to col)             (if (< to col)
141               (and (out genwrite:newline-str col) (spaces to 0))               (and (out genwrite:newline-str col)
142                      (out per-line-prefix 0)
143                      (spaces to 0))
144               (spaces (- to col) col))))               (spaces (- to col) col))))
145    
146      (define (pr obj col extra pp-pair)      (define (pr obj col extra pp-pair)
147        (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines        (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines
148          (let ((result '())          (let ((result '())
149                (left (min (+ (- (- width col) extra) 1) max-expr-width)))                (left (min (+ (- (- width col) extra) 1) max-expr-width)))
150            (generic-write obj display? #f            (generic-write obj display? #f ""
151              (lambda (str)              (lambda (str)
152                (set! result (cons str result))                (set! result (cons str result))
153                (set! left (- left (string-length str)))                (set! left (- left (string-length str)))
# Line 287  Line 290 
290    
291      (pr obj col 0 pp-expr))      (pr obj col 0 pp-expr))
292    
293      (out per-line-prefix 0)
294    (if width    (if width
295      (out genwrite:newline-str (pp obj 0))      (out genwrite:newline-str (pp obj 0))
296      (wr obj 0))      (wr obj 0))
# Line 312  Line 316 
316    
317    (rev-string-append l 0))    (rev-string-append l 0))
318    
319  ;"pp.scm" Pretty-Print  (define (pretty-print obj . opts)
320  (define (pretty-print obj . opt)    "Pretty-print OBJ on PORT, which is a keyword argument defaulting to
321    (let ((port (if (pair? opt) (car opt) (current-output-port))))  the current output port.  Formatting can be controlled by a number of
322      (generic-write obj #f 79  keyword arguments: Each line in the output is preceded by the string
323                     (lambda (s) (display s port) #t))))  PER-LINE-PREFIX, which is empty by default.  The output lines will be
324    at most WIDTH characters wide; the default is 79.  If DISPLAY? is
325    true, display rather than write representation will be used.
326    
327    Instead of with a keyword argument, you can also specify the output
328    port directly after OBJ, like (pretty-print OBJ PORT)."
329      (if (pair? opts)
330          (if (keyword? (car opts))
331              (apply pretty-print-with-keys obj opts)
332              (apply pretty-print-with-keys obj #:port (car opts) (cdr opts)))
333          (pretty-print-with-keys obj)))
334    
335    (define* (pretty-print-with-keys obj
336                                     #:key
337                                     (port (current-output-port))
338                                     (width 79)
339                                     (display? #f)
340                                     (per-line-prefix ""))
341      (generic-write obj display?
342                     (- width (string-length per-line-prefix))
343                     per-line-prefix
344                     (lambda (s) (display s port) #t)))

Legend:
Removed from v.1.5  
changed lines
  Added in v.1.6

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26