ikarus/scheme/ikarus.writer.ss

;;; Ikarus Scheme -- A compiler for R6RS Scheme.
;;; Copyright (C) 2006,2007,2008  Abdulaziz Ghuloum
;;; 
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License version 3 as
;;; published by the Free Software Foundation.
;;; 
;;; This program 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
;;; General Public License for more details.
;;; 
;;; You should have received a copy of the GNU General Public License
;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.


(library (ikarus writer)

  (export write display format printf fprintf print-error
          print-unicode print-graph put-datum traverse
          traversal-helpers)

  (import 
    (rnrs hashtables)
    (ikarus system $chars)
    (ikarus system $strings)
    (ikarus system $vectors)
    (ikarus system $fx)
    (ikarus system $pairs)
    (ikarus system $symbols)
    (ikarus system $bytevectors)
    (ikarus system $transcoders)
    (only (ikarus system $foreign) pointer? pointer->integer)
    (only (ikarus.pretty-formats) get-fmt)
    (except (ikarus) 
      write display format printf fprintf print-error print-unicode print-graph
      put-datum))

  (define print-unicode
    (make-parameter #t))


(module traversal-helpers
  (cyclic-set? shared-set? mark-set? set-mark! set-shared! shared?
               shared-bit cyclic-bit marked-bit mark-shift
               make-cache cache-string cache-object cache-next)
  ;;; association list in hash table is one of the following forms:
  ;;;
  ;;; a fixnum: 
  (define cyclic-bit         #b001)
  (define shared-bit         #b010)
  (define marked-bit         #b100)
  (define mark-shift         3)
  ;;;
  ;;; or a pair of a fixnum (above) and a cache:
  (define-struct cache (string object next))
  (define (cyclic-set? b) 
    (fx= (fxand b cyclic-bit) cyclic-bit))
  (define (shared-set? b)
    (fx= (fxand b shared-bit) shared-bit))
  (define (mark-set? b)
    (fx= (fxand b marked-bit) marked-bit))
               
  (define (set-mark! x h n)
    (let ([b (hashtable-ref h x #f)])
      (cond
        [(fixnum? b) 
         (hashtable-set! h x 
           (fxior (fxsll n mark-shift) marked-bit b))]
        [else
         (set-car! b 
           (fxior (fxsll n mark-shift) marked-bit (car b)))])))

  (define (set-shared! x h)
    (let ([b (hashtable-ref h x #f)])
      (cond
        [(fixnum? b) 
         (hashtable-set! h x (fxior shared-bit b))]
        [else
         (set-car! b (fxior shared-bit (car b)))])))
  
  (define (shared? x h)
    (cond
      [(hashtable-ref h x #f) =>
       (lambda (b) 
         (if (fixnum? b) 
             (shared-set? b)
             (let ([b (car b)])
               (shared-set? b))))]
      [else #f])))
(import traversal-helpers)


(define (cannot-happen)
  (error 'ikarus-writer "internal error"))

(define (traverse x h)
  (define (traverse-pair x h)
    (traverse (car x) h)
    (traverse (cdr x) h))
  (define (traverse-vector x h)
    (let f ([i 0] [n (vector-length x)])
      (unless (fx=? i n)
        (traverse (vector-ref x i) h)
        (f (fx+ i 1) n))))
  (define (traverse-noop x h) (void))
  (define (traverse-struct x h)
    (define (traverse-vanilla-struct x h)
      (let ([rtd (struct-type-descriptor x)])
        (unless 
          (and (record-type-descriptor? rtd)
               (record-type-opaque? rtd))
          (traverse (struct-name x) h)
          (let ([n (struct-length x)])
            (let f ([idx 0])
              (unless (fx= idx n)
                (traverse (struct-ref x idx) h)
                (f (fxadd1 idx))))))))
    (define (traverse-custom-struct x h printer)
      (let-values ([(p e) (open-string-output-port)])
        (let ([cache #f])
          (printer x p 
            (lambda (v) 
              (let ([str (e)])
                (set! cache (make-cache str v cache))
                (traverse v h))))
          (let ([cache (cons (e) cache)]
                [b (hashtable-ref h x #f)])
            (if (fixnum? b)
                (hashtable-set! h x (cons b cache))
                (cannot-happen))))))
    (let ([printer (struct-printer x)])
      (if (procedure? printer)
          (traverse-custom-struct x h printer)
          (traverse-vanilla-struct x h))))
  (define (traverse-shared x h k)
    (cond
      [(hashtable-ref h x #f) =>
       (lambda (b)
         (cond
           [(fixnum? b)
            (hashtable-set! h x (fxior b shared-bit))]
           [else
            (set-car! b (fxior (car b) shared-bit))]))]
      [else
       (hashtable-set! h x 0)
       (k x h)
       (let ([b (hashtable-ref h x #f)])
         (cond
           [(fixnum? b)
            (when (shared-set? b)
              (hashtable-set! h x (fxior b cyclic-bit)))]
           [else
            (let ([a (car b)])
              (when (shared-set? a)
                (set-car! b (fxior a cyclic-bit))))]))]))
  (define (traverse x h)
    (cond
      [(pair? x)       (traverse-shared x h traverse-pair)]
      [(vector? x)     (traverse-shared x h traverse-vector)]
      [(struct? x)     (traverse-shared x h traverse-struct)]
      [(bytevector? x) (traverse-shared x h traverse-noop)]
      [(gensym? x)     (traverse-shared x h traverse-noop)]
      [else (void)]))
  (traverse x h))

(define (wr x p m h i)
  (define (write-fixnum x p)
    (define loop
      (lambda (x p)
        (unless (fxzero? x)
          (loop (fxquotient x 10) p)
          (write-char 
             (integer->char
                (fx+ (fxremainder x 10)
                     (char->integer #\0)))
             p))))
    (cond
      [(fxzero? x) (write-char #\0 p)]
      [(fx< x 0)
       (write-char* (fixnum->string x) p)]
      [else (loop x p)]))
  (define (write-pair x p m h i)
    (define (macro x h)
      (and 
        (pair? x)
        (let ([a (car x)])
          (and (symbol? a)
            (let ([d (cdr x)])
              (and (pair? d)
                (null? (cdr d))
                (not (shared? d h))))
            (let ([p ((pretty-format a))])
              (and (pair? p)
                (eq? (car p) 'read-macro)
                (let ([d (cdr p)])
                  (and (string? d) d))))))))
    (define (f d i)
      (cond
        [(null? d) i]
        [(or (not (pair? d)) (shared? d h))
         (write-char #\space p)
         (write-char #\. p)
         (write-char #\space p)
         (wr d p m h i)]
        [else
         (write-char #\space p)
         (let ([i (wr (car d) p m h i)])
           (f (cdr d) i))]))
    (cond
      [(macro x h) =>
       (lambda (a) 
         (write-string a p #f)
         (wr (cadr x) p m h i))]
      [else
       (write-char #\( p)
       (let ([i (f (cdr x) (wr (car x) p m h i))])
         (write-char #\) p)
         i)]))
  (define (write-vector x p m h i)
    (define (f x p m h i idx n)
      (cond
        [(fx= idx n) i]
        [else 
         (write-char #\space p)
         (let ([i (wr (vector-ref x idx) p m h i)])
           (f x p m h i (fx+ idx 1) n))]))
    (write-char #\# p)
    (let ([n (vector-length x)])
      (cond
        [(fx=? n 0) 
         (write-char #\( p)
         (write-char #\) p)
         i]
        [else
         (write-char #\( p)
         (let ([i (wr (vector-ref x 0) p m h i)])
           (f x p m h i 1 n)
           (write-char #\) p)
           i)])))
  (define (write-bytevector x p m h i)
    (write-char #\# p)
    (write-char #\v p)
    (write-char #\u p)
    (write-char #\8 p)
    (write-char #\( p)
    (let ([n (bytevector-length x)])
      (when (fx> n 0)
        (write-fixnum (bytevector-u8-ref x 0) p)
        (let f ([idx 1] [n n] [x x] [p p])
          (unless (fx= idx n)
            (write-char #\space p)
            (write-fixnum (bytevector-u8-ref x idx) p)
            (f (fxadd1 idx) n x p)))))
    (write-char #\) p)
    i)
  (define (write-positive-hex-fx n p)
    (unless (fx= n 0)
      (write-positive-hex-fx (fxsra n 4) p)
      (let ([n (fxand n #xF)])
        (cond
          [(fx<= n 9)
           (write-char (integer->char 
                         (fx+ (char->integer #\0) n))
                       p)]
          [else
           (write-char (integer->char
                         (fx+ (char->integer #\A) (fx- n 10)))
                       p)]))))
  (define (write-inline-hex b p)
    (write-char #\\ p)
    (write-char #\x p)
    (if (fxzero? b)
        (write-char #\0 p)
        (write-positive-hex-fx b p))
    (write-char #\; p))
  (define (write-character x p m)
    (define char-table ; first nonprintable chars
      '#("nul" "x1" "x2" "x3" "x4" "x5" "x6" "alarm"
         "backspace" "tab" "linefeed" "vtab" "page" "return" "xE" "xF" 
         "x10" "x11" "x12" "x13" "x14" "x15" "x16" "x17" 
         "x18" "x19" "x1A" "esc" "x1C" "x1D" "x1E" "x1F" 
         "space"))
    (if m 
        (let ([i (char->integer x)])
          (write-char #\# p)
          (cond
           [(fx< i (vector-length char-table))
            (write-char #\\ p)
            (write-char* (vector-ref char-table i) p)]
           [(fx< i 127)
            (write-char #\\ p)
            (write-char x p)]
           [(fx= i 127) 
            (write-char #\\ p)
            (write-char* "delete" p)]
           [(and (print-unicode) (unicode-printable-char? x))
            (write-char #\\ p)
            (write-char x p)]
           [else
            (write-char #\\ p)
            (write-char #\x p)
            (write-positive-hex-fx i p)]))
        (write-char x p)))
  (define (write-string x p m)
    (define (write-string-escape x p)
      ;;; commonize with write-symbol-bar-escape
      (define (loop x i n p)
        (unless (fx= i n)
          (let* ([c (string-ref x i)]
                 [b (char->integer c)])
            (cond
              [(fx< b 32) 
               (cond
                 [(fx< b 7) 
                  (write-inline-hex b p)]
                 [(fx< b 14)
                  (write-char #\\ p)
                  (write-char (string-ref "abtnvfr" (fx- b 7)) p)]
                 [else 
                  (write-inline-hex b p)])]
              [(or (char=? #\" c) (char=? #\\ c))
               (write-char #\\ p)
               (write-char c p)]
              [(fx< b 127)
               (write-char c p)]
              [(print-unicode) 
               (write-char c p)]
              [else
               (write-inline-hex b p)]))
          (loop x (fxadd1 i) n p)))
      (write-char #\" p)
      (loop x 0 (string-length x) p)
      (write-char #\" p))
    (if m 
        (write-string-escape x p) 
        (write-char* x p)))
  (module (write-gensym write-symbol)
    (define (write-gensym x p m h i)
      (cond
        [(and m (print-gensym)) =>
         (lambda (gensym-how)
           (case gensym-how
             [(pretty)
              (let ([str (symbol->string x)])
                (write-char #\# p)
                (write-char #\: p)
                (write-symbol-string str p m))]
             [else
              (let ([str (symbol->string x)]
                    [ustr (gensym->unique-string x)])
                (write-char #\# p)
                (write-char #\{ p)
                (write-symbol-string str p m)
                (write-char #\space p)
                (write-symbol-bar-esc ustr p)
                (write-char #\} p))])
           i)]
        [else 
         (write-symbol x p m)
         i]))
    (define write-symbol-bar-esc
      (lambda (x p)
        (define write-symbol-bar-esc-loop
          (lambda (x i n p)
            (unless (fx= i n)
              (let* ([c (string-ref x i)]
                     [b (char->integer c)])
                (cond
                  [(fx< b 32)
                   (cond
                     [(fx< b 7) 
                      (write-inline-hex b p)]
                     [(fx< b 14)
                      (write-char #\\ p)
                      (write-char (string-ref "abtnvfr" (fx- b 7)) p)]
                     [else 
                      (write-inline-hex b p)])]
                  [(memq c '(#\\ #\|))
                   (write-char #\\ p)
                   (write-char c p)]
                  [(fx< b 127) 
                   (write-char c p)]
                  [else 
                   (write-inline-hex b p)]))
              (write-symbol-bar-esc-loop x (fxadd1 i) n p))))
        (write-char #\| p)
        (write-symbol-bar-esc-loop x 0 (string-length x) p)
        (write-char #\| p)))
    (define (write-symbol-string str p m)
      (define-syntax ascii-map
        (lambda (x)
          (syntax-case x ()
            [(stx str) (string? (syntax->datum #'str))
             (let ([s (syntax->datum #'str)]
                   [bv (make-bytevector 16 0)])
               (for-each
                 (lambda (c)
                   (let ([b (char->integer c)])
                     (let ([i (fxlogand b 7)]
                           [j (fxsra b 3)])
                       (bytevector-u8-set! bv j
                         (fxlogor (bytevector-u8-ref bv j)
                           (fxsll 1 i))))))
                 (string->list s))
               (with-syntax ([bv (datum->syntax #'stx bv)])
                 #'(quote bv)))])))
      (define subsequents-map 
        (ascii-map
          "!$%&*/:<=>?^_~+-.@abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"))
      (define initials-map
        (ascii-map
          "!$%&*/:<=>?^_~abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"))
      (define initial-categories 
        '(Lu Ll Lt Lm Lo Mn Nl No Pd Pc Po Sc Sm Sk So Co))
      (define subsequent-categories
        '(Nd Mc Me))
      (define (in-map? byte map)
        (let ([i (fxand byte 7)]
              [j (fxsra byte 3)])
          (and 
            (fx< j (bytevector-length map))
            (let ([mask (fxsll 1 i)])
               (not (fxzero? 
                      (fxlogand mask
                        (bytevector-u8-ref map j))))))))
      (define (subsequent*? str i n)
        (or (fx= i n)
            (and (subsequent? (string-ref str i))
                 (subsequent*? str (fxadd1 i) n))))
      (define (subsequent? x)
        (define (digit? c)
          (and (char<=? #\0 c) (char<=? c #\9)))
        (define (special-subsequent? x)
          (memq x '(#\+ #\- #\. #\@)))
        (define (special-initial? x)
          (memq x '(#\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\^ #\_ #\~)))
        (define (letter? c)
          (or (and (char<=? #\a c) (char<=? c #\z))
              (and (char<=? #\A c) (char<=? c #\Z))))
        (define (initial? c)
          (or (letter? c) (special-initial? c)))
        (or (initial? x)
            (digit? x)
            (special-subsequent? x)))
      (define (peculiar-symbol-string? str)
        (let ([n (string-length str)])
          (cond
            [(fx= n 1) 
             (memq (string-ref str 0) '(#\+ #\-))]
            [(fx>= n 2)
             (or (and (char=? (string-ref str 0) #\-)
                      (char=? (string-ref str 1) #\>)
                      (subsequent*? str 2 n))
                 (string=? str "..."))]
            [else #f])))
      (define (write-symbol-hex-esc str p)
        (let ([n (string-length str)])
          (cond
            [(fx= n 0) 
             (write-char #\| p) 
             (write-char #\| p)]
            [else
             (let* ([c0 (string-ref str 0)]
                    [b0 (char->integer c0)])
               (cond
                 [(in-map? b0 initials-map) 
                  (write-char c0 p)]
                 [(fx< b0 128) (write-inline-hex b0 p)]
                 [(and (print-unicode)
                    (memq (char-general-category c0) initial-categories))
                  (write-char c0 p)]
                 [else (write-inline-hex b0 p)])
               (write-subsequent* str 1 n p))])))
      (define (write-subsequent* str i j p)
        (unless (fx= i j)
          (let* ([c (string-ref str i)]
                 [b (char->integer c)])
            (cond
              [(in-map? b subsequents-map) 
               (write-char c p)]
              [(fx< b 128) 
               (write-inline-hex b p)]
              [(and (print-unicode) 
                 (let ([cat (char-general-category c)])
                   (or (memq cat initial-categories)
                       (memq cat subsequent-categories))))
               (write-char c p)]
              [else 
               (write-inline-hex b p)]))
          (write-subsequent* str (fxadd1 i) j p)))
      (define (write-peculiar str p)
        (let ([n (string-length str)])
          (cond
            [(fx= n 1) 
             (write-char (string-ref str 0) p)]
            [(and (fx>= n 2) 
                  (char=? (string-ref str 0) #\-)
                  (char=? (string-ref str 1) #\>))
             (write-char #\- p)
             (write-char #\> p)
             (write-subsequent* str 2 n p)]
            [(string=? str "...")
             (write-char #\. p)
             (write-char #\. p)
             (write-char #\. p)]
            [else (error 'write-peculiear "BUG")])))
        (if m
            (if (peculiar-symbol-string? str)
                (write-peculiar str p)
                (write-symbol-hex-esc str p))
            (write-char* str p)))
    (define (write-symbol x p m)
      (write-symbol-string (symbol->string x) p m)))
  (define (write-struct x p m h i)
    (define (write-vanilla-struct x p m h i)
      (cond
        [(let ([rtd (struct-type-descriptor x)])
           (and (record-type-descriptor? rtd) 
                (record-type-opaque? rtd)))
         (write-char* "#<unknown>" p)
         i]
        [else
         (write-char #\# p)
         (write-char #\[ p)
         (let ([i (wr (struct-name x) p m h i)])
           (let ([n (struct-length x)])
             (let f ([idx 0] [i i])
               (cond
                 [(fx= idx n)
                  (write-char #\] p)
                  i]
                 [else 
                  (write-char #\space p)
                  (f (fxadd1 idx) 
                     (wr (struct-ref x idx) p m h i))]))))]))
    (define (write-custom-struct out p m h i)
      (let ([i 
             (let f ([cache (cdr out)])
               (cond
                 [(not cache) i]
                 [else
                  (let ([i (f (cache-next cache))])
                    (write-char* (cache-string cache) p)
                    (wr (cache-object cache) p m h i))]))])
        (write-char* (car out) p)
        i))
    (let ([b (hashtable-ref h x #f)])
      (cond
        [(pair? b)
         (write-custom-struct (cdr b) p m h i)]
        [else (write-vanilla-struct x p m h i)])))
  (define (write-char* x p)
    (let f ([x x] [p p] [i 0] [n (string-length x)])
      (unless (fx=? i n) 
        (write-char (string-ref x i) p)
        (f x p (fx+ i 1) n))))
  (define (write-procedure x p)
    (write-char* "#<procedure" p)
    (let-values ([(name src) 
                  (let ([ae (procedure-annotation x)])
                    (if (pair? ae)
                        (values (car ae) (cdr ae))
                        (if (symbol? ae)
                            (values ae #f)
                            (values #f #f))))])
      (when (symbol? name)
        (write-char* " " p)
        (display name p))
      (when (pair? src)
        (let ([file (car src)] [char (cdr src)])
          (write-char* " [char " p)
          (display char p)
          (write-char* " of " p)
          (display file p)
          (write-char* "]" p))))
    (write-char* ">" p))
  (define (write-port x p)
    (write-char* "#<" p)
    (write-char* (if (output-port? x) "output" "input") p)
    (write-char* "-port " p)
    (write-char* (if (binary-port? x) "(binary) " "(textual) ") p)
    (let ([i (wr (port-id x) p #t h i)])
      (write-char #\> p)
      i))
  (define (write-hex x n p)
    (define s "0123456789ABCDEF")
    (unless (zero? n)
      (write-hex (sra x 4) (- n 1) p)
      (write-char (string-ref s (bitwise-and x #xF)) p)))
  (define (write-shared x p m h i k)
    (let ([b (hashtable-ref h x #f)])
      (let ([b (if (fixnum? b) b (car b))])
        (cond
          [(mark-set? b)
           (write-char #\# p)
           (write-fixnum (fxsra b mark-shift) p)
           (write-char #\# p)
           i]
          [(or (cyclic-set? b)
               (and (shared-set? b) (print-graph)))
           (let ([n i])
             (set-mark! x h n)
             (write-char #\# p)
             (write-fixnum n p)
             (write-char #\= p)
             (k x p m h (+ i 1)))]
          [else
           (k x p m h i)]))))
  (define (wr x p m h i)
    (cond
      [(pair? x)   (write-shared x p m h i write-pair)]
      [(symbol? x)
       (if (gensym? x)
           (write-shared x p m h i write-gensym)
           (begin (write-symbol x p m) i))]
      [(fixnum? x) (write-fixnum x p) i]
      [(string? x) (write-string x p m) i]
      [(boolean? x)
       (write-char #\# p)
       (write-char (if x #\t #\f) p)
       i]
      [(char? x) (write-character x p m) i]
      [(null? x) (write-char #\( p) (write-char #\) p) i]
      [(number? x) (write-char* (number->string x) p) i]
      [(vector? x) (write-shared x p m h i write-vector)]
      [(bytevector? x) (write-shared x p m h i write-bytevector)]
      [(procedure? x) (write-procedure x p) i]
      [(port? x) (write-port x p) i]
      [(eq? x (void)) (write-char* "#<void>" p) i]
      [(eof-object? x) (write-char* "#!eof" p) i]
      [(bwp-object? x) (write-char* "#!bwp" p) i]
      [(transcoder? x) (write-char* "#<transcoder>" p) i]
      [(struct? x) (write-shared x p m h i write-struct)]
      [(code? x) (write-char* "#<code>" p) i]
      [(pointer? x) 
       (write-char* "#<pointer #x" p)
       (write-hex
         (pointer->integer x)
         (if (<= (fixnum-width) 32) 8 16)
         p)
       (write-char* ">" p)]
      [($unbound-object? x) (write-char* "#<unbound-object>" p) i]
      [else (write-char* "#<unknown>" p) i]))
  (wr x p m h i))







  (define print-graph (make-parameter #f))
  
  (define (write-to-port x p)
    (let ([h (make-eq-hashtable)])
      (traverse x h)
      (wr x p #t h 0))
    (flush-output-port p))
  
  (define (display-to-port x p)
    (let ([h (make-eq-hashtable)])
      (traverse x h)
      (wr x p #f h 0))
    (flush-output-port p))
  
  (define formatter
    (lambda (who p fmt args)
      ;;; first check
      (let f ([i 0] [args args])
        (cond
          [(fx= i (string-length fmt))
           (unless (null? args) 
             (die who 
               (format 
                 "extra arguments given for format string \x2036;~a\x2033;"
                 fmt)))]
          [else
           (let ([c (string-ref fmt i)])
             (cond
               [(eqv? c #\~)
                (let ([i (fxadd1 i)])
                  (when (fx= i (string-length fmt))
                    (die who "invalid ~ at end of format string" fmt))
                  (let ([c (string-ref fmt i)])
                   (cond
                     [(memv c '(#\~ #\%)) (f (fxadd1 i) args)]
                     [(memv c '(#\a #\s))
                      (when (null? args)
                        (die who "insufficient arguments"))
                      (f (fxadd1 i) (cdr args))]
                     [(memv c '(#\b #\o #\x #\d))
                      (when (null? args)
                        (die who "insufficient arguments"))
                      (let ([a (car args)])
                        (unless (number? a) (die who "not a number" a))
                        (unless (or (eqv? c #\d) (exact? a))
                          (die who 
                            (format "inexact numbers cannot be \
                                     printed with ~~~a" c)
                            a)))
                      (f (fxadd1 i) (cdr args))]
                     [else
                      (die who "invalid sequence character after ~" c)])))]
               [else (f (fxadd1 i) args)]))]))
      ;;; then format
      (let f ([i 0] [args args])
        (unless (fx= i (string-length fmt))
          (let ([c (string-ref fmt i)])
            (cond
              [(eqv? c #\~)
               (let ([i (fxadd1 i)])
                 (let ([c (string-ref fmt i)])
                  (cond
                    [(eqv? c #\~) 
                     (write-char #\~ p)
                     (f (fxadd1 i) args)]
                    [(eqv? c #\%) 
                     (write-char #\newline p)
                     (f (fxadd1 i) args)] 
                    [(eqv? c #\a)
                     (display-to-port (car args) p)
                     (f (fxadd1 i) (cdr args))]
                    [(eqv? c #\s)
                     (write-to-port (car args) p)
                     (f (fxadd1 i) (cdr args))]
                    [(assv c '([#\b . 2] [#\o . 8] [#\x . 16] [#\d . 10]))
                     =>
                     (lambda (x)
                       (let ([a (car args)])
                         (display-to-port (number->string a (cdr x)) p))
                       (f (fxadd1 i) (cdr args)))]
                    [else (die who "BUG" c)])))]
              [else 
               (write-char c p)
               (f (fxadd1 i) args)]))))
      ;;; then flush
      (flush-output-port p)))
  
  (define fprintf
    (lambda (p fmt . args)
      (assert-open-textual-output-port p 'fprintf)
      (unless (string? fmt)
        (die 'fprintf "not a string" fmt))
      (formatter 'fprintf p fmt args)))

  (define display-error
    (lambda (errname who fmt args)
      (unless (string? fmt)
        (die 'print-error "not a string" fmt))
      (let ([p (standard-error-port)])
        (if who
            (fprintf p "~a in ~a: " errname who)
            (fprintf p "~a: " errname))
        (formatter 'print-error p fmt args)
        (write-char #\. p)
        (newline p))))
  
  (define format
    (lambda (fmt . args)
      (unless (string? fmt)
        (die 'format "not a string" fmt))
      (let-values ([(p e) (open-string-output-port)])
        (formatter 'format p fmt args)
        (e))))
   
  (define printf 
    (lambda (fmt . args)
      (unless (string? fmt)
        (die 'printf "not a string" fmt))
      (formatter 'printf (current-output-port) fmt args)))
  
  (define write 
    (case-lambda
      [(x) (write-to-port x (current-output-port))]
      [(x p)
       (assert-open-textual-output-port p 'write)
       (write-to-port x p)]))

  (define (put-datum p x)
    (assert-open-textual-output-port p 'put-datum)
    (write-to-port x p))

  (define display 
    (case-lambda
      [(x) (display-to-port x (current-output-port))]
      [(x p)
       (assert-open-textual-output-port p 'display)
       (display-to-port x p)]))

  (define print-error 
    (lambda (who fmt . args)
      (display-error "Error" who fmt args)))

  (define warning 
    (lambda (who fmt . args)
      (display-error "Warning" who fmt args)))

  (define (assert-open-textual-output-port p who)
    (unless (output-port? p) 
      (die who "not an output port" p))
    (unless (textual-port? p) 
      (die who "not a textual port" p))
    (when (port-closed? p) 
      (die who "port is closed" p)))

  )