From: Chris Hanson Date: Thu, 2 Jan 2003 01:55:19 +0000 (+0000) Subject: New procedure WRITE-STRINGS-AS-TABLE is used to format the ID strings X-Git-Tag: 20090517-FFI~2079 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=07a98d50ae4e3c527875e9c8f3329462a89c2d91;p=mit-scheme.git New procedure WRITE-STRINGS-AS-TABLE is used to format the ID strings printed by IDENTIFY-WORLD. --- diff --git a/v7/src/runtime/output.scm b/v7/src/runtime/output.scm index 63ef69b14..40da300d8 100644 --- a/v7/src/runtime/output.scm +++ b/v7/src/runtime/output.scm @@ -1,8 +1,10 @@ #| -*-Scheme-*- -$Id: output.scm,v 14.26 2003/01/01 02:25:54 cph Exp $ +$Id: output.scm,v 14.27 2003/01/02 01:52:51 cph Exp $ -Copyright (c) 1988-2002 Massachusetts Institute of Technology +Copyright (c) 1986,1987,1988,1989,1990 Massachusetts Institute of Technology +Copyright (c) 1991,1992,1993,1999,2001 Massachusetts Institute of Technology +Copyright (c) 2002,2003 Massachusetts Institute of Technology This file is part of MIT Scheme. @@ -166,4 +168,125 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (output-port/flush-output (if (default-object? port) (current-output-port) - (guarantee-output-port port 'FLUSH-OUTPUT)))) \ No newline at end of file + (guarantee-output-port port 'FLUSH-OUTPUT)))) + +;;;; Tabular output + +(define (write-strings-as-table strings port row-major? min-minor + left-margin col-sep right-margin) + (if (not (list-of-type? strings string?)) + (error:wrong-type-argument strings "list of strings" + 'WRITE-STRINGS-AS-TABLE)) + (guarantee-output-port port 'WRITE-STRINGS-AS-TABLE) + (guarantee-exact-positive-integer min-minor 'WRITE-STRINGS-AS-TABLE) + (guarantee-string left-margin 'WRITE-STRINGS-AS-TABLE) + (guarantee-string col-sep 'WRITE-STRINGS-AS-TABLE) + (guarantee-string right-margin 'WRITE-STRINGS-AS-TABLE) + (let ((n-strings (length strings)) + (max-width (output-port/x-size port)) + (lm-width (string-length left-margin)) + (cs-width (string-length col-sep)) + (rm-width (string-length right-margin))) + + (define (do-row-major) + (do-it (let loop + ((strings (cdr strings)) + (width (+ lm-width rm-width (string-length (car strings)))) + (n-cols 1)) + (if (and (< width max-width) + (pair? strings)) + (let ((width* + (+ width cs-width (string-length (car strings))))) + (if (<= width* max-width) + (loop (cdr strings) width* (+ n-cols 1)) + (max n-cols min-minor))) + (max n-cols min-minor))) + (lambda (n-cols) (- n-cols 1)) + (lambda (n-cols) (= n-cols min-minor)) + (lambda (n-cols) + (let ((cols (make-list n-cols '()))) + (do ((strings strings (cdr strings)) + (p cols (if (pair? (cdr p)) (cdr p) cols))) + ((not (pair? strings))) + (set-car! p (cons (car strings) (car p)))) + (do ((p cols (cdr p))) + ((not (pair? p))) + (set-car! p (reverse! (car p)))) + cols)) + (lambda () + (write-string left-margin port) + (for-each (lambda (string) + (write-string col-sep port) + (write-string string port)) + strings) + (write-string right-margin port) + (newline port)))) + + (define (do-col-major) + (do-it min-minor + (lambda (n-rows) (+ n-rows 1)) + (lambda (n-rows) n-rows #f) + (lambda (n-rows) + (let loop + ((strings strings) + (n-strings (length strings)) + (cols '())) + (if (> n-strings n-rows) + (loop (list-tail strings n-rows) + (- n-strings n-rows) + (cons (list-head strings n-rows) cols)) + (reverse! + (if (> n-strings 0) (cons strings cols) cols))))) + (lambda () + (for-each (lambda (string) + (write-string left-margin port) + (write-string string port) + (write-string right-margin port) + (newline port)) + strings)))) + + (define (do-it start-n-minor step-minor limit-n-minor? ->cols single-major) + (let loop ((n-minor start-n-minor)) + (if (<= n-minor n-strings) + (let* ((cols (->cols n-minor)) + (col-widths + (map (lambda (col) + (apply max (map string-length col))) + cols))) + (if (or (limit-n-minor? n-minor) + (<= (apply + + lm-width + (* cs-width (- (length cols) 1)) + rm-width + col-widths) + max-width)) + (write-cols cols col-widths) + (loop (step-minor n-minor)))) + (single-major)))) + + (define (write-cols cols col-widths) + (do () + ((not (pair? (car cols)))) + (do ((cols cols (cdr cols)) + (col-widths col-widths (cdr col-widths)) + (prefix left-margin col-sep)) + ((not (pair? cols))) + (let ((strings (car cols))) + (if (pair? strings) + (begin + (write-string prefix port) + (write-string (car strings) port) + (do ((n (- (car col-widths) (string-length (car strings))) + (- n 1))) + ((= n 0)) + (write-char #\space port)) + (set-car! cols (cdr strings))) + (begin + (write-string prefix port) + (do ((n (car col-widths) (- n 1))) + ((= n 0)) + (write-char #\space port)))))) + (write-string right-margin port) + (newline port))) + + (if row-major? (do-row-major) (do-col-major)))) \ No newline at end of file diff --git a/v7/src/runtime/savres.scm b/v7/src/runtime/savres.scm index 91e656dc7..7745a74e7 100644 --- a/v7/src/runtime/savres.scm +++ b/v7/src/runtime/savres.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: savres.scm,v 14.37 2003/01/02 01:52:39 cph Exp $ +$Id: savres.scm,v 14.38 2003/01/02 01:55:19 cph Exp $ Copyright (c) 1988,1989,1990,1991,1992 Massachusetts Institute of Technology Copyright (c) 1995,1998,1999,2000,2001 Massachusetts Institute of Technology @@ -165,11 +165,11 @@ warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.") (write-string " at " port) (write-string (decoded-time/time-string time-world-saved) port) (newline port))) - (write-string-table (map get-subsystem-identification-string - (get-subsystem-names)) - port - #f - 1 - "|| " - " || " - " ||"))) \ No newline at end of file + (write-strings-as-table (map get-subsystem-identification-string + (get-subsystem-names)) + port + #f + 1 + "|| " + " || " + " ||"))) \ No newline at end of file