ikarus/src/ikarus.writer.ss

(library (ikarus writer)
  (export write display format printf print-error error-handler
          error)
  (import 
    (ikarus system $chars)
    (ikarus system $strings)
    (ikarus system $fx)
    (ikarus system $pairs)
    (ikarus system $symbols)
    (ikarus system $bytevectors)
    (except (ikarus) write display format printf print-error
            error-handler error))

  (define char-table ; first nonprintable chars
    '#("nul" "soh" "stx" "etx" "eot" "enq" "ack" "bel" "bs" "tab" "newline"
       "vt" "ff" "return" "so" "si" "dle" "dc1" "dc2" "dc3" "dc4" "nak" 
       "syn" "etb" "can" "em" "sub" "esc" "fs" "gs" "rs" "us" "space"))

  (define write-character
    (lambda (x p m)
      (if m 
          (let ([i ($char->fixnum 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* "del" p)]
             [else
              (write-char #\\ p)
              (write-char #\x p)
              (write-fixnum i p)]))
          (write-char x p))))

  (define write-list
    (lambda (x p m h i)
      (cond
       [(and (pair? x) 
             (or (not (get-hash-table h x #f))
                 (fxzero? (get-hash-table h x 0))))
        (write-char #\space p)
        (write-list (cdr x) p m h 
          (writer (car x) p m h i))]
       [(null? x) i]
       [else
        (write-char #\space p)
        (write-char #\. p)
        (write-char #\space p)
        (writer x p m h i)])))

  (define write-vector
    (lambda (x p m h i)
      (write-char #\# p)
      (write-char #\( p)
      (let ([n (vector-length x)])
        (let ([i 
               (cond
                 [(fx> n 0)
                  (let f ([idx 1] [i (writer (vector-ref x 0) p m h i)])
                    (cond
                      [(fx= idx n)
                       i]
                      [else
                       (write-char #\space p)
                       (f (fxadd1 idx)
                          (writer (vector-ref x idx) p m h i))]))]
                 [else i])])
           (write-char #\) p)
           i))))

  (define write-bytevector
    (lambda (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)])
        (let ([i
               (cond
                 [(fx> n 0)
                  (let f ([idx 1] [i (writer ($bytevector-u8-ref x 0) p m h i)])
                    (cond
                      [(fx= idx n)
                       i]
                      [else
                       (write-char #\space p)
                       (f (fxadd1 idx)
                          (writer (bytevector-u8-ref x idx) p m h i))]))]
                 [else i])])
           (write-char #\) p)
           i))))

  (define write-record
    (lambda (x p m h i)
      (write-char #\# p)
      (write-char #\[ p)
      (let ([i (writer (record-name x) p m h i)])
        (let ([n (record-length x)])
          (let f ([idx 0] [i i])
            (cond
              [(fx= idx n)
               (write-char #\] p)
               i]
              [else 
               (write-char #\space p)
               (f (fxadd1 idx) 
                  (writer (record-ref x idx) p m h i))]))))))
  
  (define initial?
    (lambda (c)
      (or (letter? c) (special-initial? c))))
  
  (define letter?
    (lambda (c)
      (or (and ($char<= #\a c) ($char<= c #\z))
          (and ($char<= #\A c) ($char<= c #\Z)))))
  
  (define digit?
    (lambda (c)
      (and ($char<= #\0 c) ($char<= c #\9))))
  
  (define special-initial? 
    (lambda (x)
      (memq x '(#\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\^ #\_ #\~))))
  
  (define subsequent?
    (lambda (x)
      (or (initial? x)
          (digit? x)
          (special-subsequent? x))))
  
  (define special-subsequent?
    (lambda (x) 
      (memq x '(#\+ #\- #\. #\@))))
  
  (define subsequent*?
    (lambda (str i n)
      (or ($fx= i n)
          (and (subsequent? ($string-ref str i))
               (subsequent*? str ($fxadd1 i) n)))))
  
  (define valid-symbol-string?
    (lambda (str)
      (define normal-symbol-string?
        (lambda (str)
          (let ([n ($string-length str)])
            (and ($fx>= n 1)
                 (initial? ($string-ref str 0))
                 (subsequent*? str 1 n)))))
      (define peculiar-symbol-string?
        (lambda (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 "..."))]))))
      (or (normal-symbol-string? str)
          (peculiar-symbol-string? str))))
  
  (define write-symbol-esc-loop
    (lambda (x i n p)
      (unless ($fx= i n)
        (let ([c ($string-ref x i)])
          (when (memq c '(#\\ #\|))
            (write-char #\\ p))
          (write-char c p))
        (write-symbol-esc-loop x ($fxadd1 i) n p))))
  
  (define write-symbol-esc
    (lambda (x p)
      (write-char #\| p)
      (write-symbol-esc-loop x 0 ($string-length x) p)
      (write-char #\| p)))
  
  (define write-symbol
    (lambda (x p m)
      (let ([str (symbol->string x)])
        (if m
            (if (valid-symbol-string? str)
                (write-char* str p)
                (write-symbol-esc str p))
            (write-char* str p)))))
  
  (define write-gensym
    (lambda (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)
                (if (valid-symbol-string? str)
                    (write-char* str p)
                    (write-symbol-esc str p)))]
             [else
              (let ([str (symbol->string x)])
                (write-char #\# p)
                (write-char #\{ p)
                (if (valid-symbol-string? str)
                    (write-char* str p)
                    (write-symbol-esc str p))
                (write-char #\space p)
                (write-symbol-esc (gensym->unique-string x) p)
                (write-char #\} p))])
           i)]
        [else 
         (write-symbol x p m)
         i])))
  
  (define write-string-escape
    (lambda (x p)
      (define loop 
        (lambda (x i n p)
         (unless (fx= i n)
           (let ([c (string-ref x i)])
             (cond
               [(or ($char= #\" c) ($char= #\\ c))
                (write-char #\\ p)
                (write-char c p)]
               [($char= #\newline c)
                (write-char #\\ p)
                (write-char #\n p)] 
               [($char= #\return c)
                (write-char #\\ p)
                (write-char #\r p)] 
               [($char= #\tab c)
                (write-char #\\ p)
                (write-char #\t p)]
               [else
                (write-char c p)]))
           (loop x (fxadd1 i) n p)))) 
      (write-char #\" p)
      (loop x 0 (string-length x) p)
      (write-char #\" p)))
  
  (define write-string
    (lambda (x p m)
      (if m
          (write-string-escape x p)
          (write-char* x p))))
  
  (define write-fixnum
    (lambda (x p)
      (define loop
        (lambda (x p)
          (unless (fxzero? x)
            (loop (fxquotient x 10) p)
            (write-char 
               ($fixnum->char
                  ($fx+ (fxremainder x 10)
                        ($char->fixnum #\0)))
               p))))
      (cond
       [(fxzero? x) (write-char #\0 p)]
       [(fx< x 0)
        (write-char #\- p)
        (if (fx= x -536870912)
            (write-char* "536870912" p)
            (loop (fx- 0 x) p))]
       [else (loop x p)])))
  
  (define write-char*
    (lambda (x p)
      (define loop 
        (lambda (x i n p)
         (unless (fx= i n)
           (write-char (string-ref x i) p)
           (loop x (fxadd1 i) n p)))) 
      (loop x 0 (string-length x) p)))
  
  (define macro
    (lambda (x)
      (define macro-forms
        '([quote .            "'"]
          [quasiquote .       "`"]
          [unquote .          ","]
          [unquote-splicing . ",@"]
          [syntax .           "#'"]
          [|#primitive| .     "#%"]))
      (and (pair? x)
           (let ([d ($cdr x)])
             (and (pair? d)
                  (null? ($cdr d))))
           (assq ($car x) macro-forms))))
  
  (define write-pair
    (lambda (x p m h i)
      (write-char #\( p)
      (let ([i (writer (car x) p m h i)])
        (let ([i (write-list (cdr x) p m h i)])
          (write-char #\) p)
          i))))
  
  (define write-ref
    (lambda (n p)
      (write-char #\# p)
      (write-fixnum (fx- -1 n) p)
      (write-char #\# p)))
  
  (define write-mark
    (lambda (n p)
      (write-char #\# p)
      (write-fixnum (fx- -1 n) p)
      (write-char #\= p)))
  
  (define write-shareable
    (lambda (x p m h i k)
      (cond
        [(get-hash-table h x #f) =>
         (lambda (n)
           (cond
             [(fx< n 0) 
              (write-ref n p)
              i]
             [(fx= n 0)
              (k x p m h i)]
             [else
              (let ([i (fx- i 1)])
                (put-hash-table! h x i)
                (write-mark i p)
                (k x p m h i))]))]
        [else (k x p m h i)])))
  
  (define writer
    (lambda (x p m h i)
      (cond
        [(pair? x) 
         (write-shareable x p m h i write-pair)]
        [(symbol? x)
         (if (gensym? x)
             (write-gensym x p m h i)
             (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* (if x "#t" "#f") p)
         i]
        [(char? x)
         (write-character x p m)
         i]
        [(procedure? x)
         (write-char* "#<procedure>" p)
         i]
        [(output-port? x)
         (write-char* "#<output-port " p)
         (let ([i (writer (output-port-name x) p #t h i)])
           (write-char #\> p)
           i)]
        [(input-port? x)
         (write-char* "#<input-port " p)
         (let ([i (writer (input-port-name x) p #t h i)])
           (write-char #\> p)
           i)]
        [(vector? x)
         (write-shareable x p m h i write-vector)]
        [(bytevector? x)
         (write-shareable x p m h i write-bytevector)]
        [(null? x) 
         (write-char #\( p)
         (write-char #\) 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]
        [(hash-table? x)
         (write-char* "#<hash-table>" p)
         i]
        [(record? x)
         (let ([printer (record-printer x)])
           (if (procedure? printer)
               (begin (printer x p) i)
               (write-shareable x p m h i write-record)))]
        [(code? x)
         (write-char* "#<code>" p)]
        [($unbound-object? x)
         (write-char* "#<unbound-object>" p)
         i]
       ;;; [($forward-ptr? x) FIXME reinstate
       ;;;  (write-char* "#<forward-ptr>" p)
       ;;;  i]
        [(number? x)
         (write-char* (number->string x) p)
         i]
        [else 
         (write-char* "#<unknown>" p)
         i])))
  
  (define print-graph (make-parameter #f))
  
  (define (hasher x h)
    (define (vec-graph x i j h)
      (unless (fx= i j)
        (graph (vector-ref x i) h)
        (vec-graph x (fxadd1 i) j h)))
    (define (vec-dynamic x i j h)
      (unless (fx= i j)
        (dynamic (vector-ref x i) h)
        (vec-dynamic x (fxadd1 i) j h))) 
    (define (graph x h)
      (cond
        [(pair? x)
         (cond
           [(get-hash-table h x #f) =>
            (lambda (n)
              (put-hash-table! h x (fxadd1 n)))]
           [else
            (put-hash-table! h x 0)
            (graph (car x) h)
            (graph (cdr x) h)])]
        [(vector? x)
         (cond
           [(get-hash-table h x #f) =>
            (lambda (n)
              (put-hash-table! h x (fxadd1 n)))]
           [else
            (put-hash-table! h x 0)
            (vec-graph x 0 (vector-length x) h)])]
        [(gensym? x)
         (cond
           [(get-hash-table h x #f) =>
            (lambda (n)
              (put-hash-table! h x (fxadd1 n)))])]))
    (define (dynamic x h)
      (cond
        [(pair? x)
         (cond
           [(get-hash-table h x #f) =>
            (lambda (n)
              (put-hash-table! h x (fxadd1 n)))]
           [else
            (put-hash-table! h x 0)
            (dynamic (car x) h)
            (dynamic (cdr x) h)
            (when (and (get-hash-table h x #f)
                       (fxzero? (get-hash-table h x #f)))
              (put-hash-table! h x #f))])]
        [(vector? x)
         (cond
           [(get-hash-table h x #f) =>
            (lambda (n)
              (put-hash-table! h x (fxadd1 n)))]
           [else
            (put-hash-table! h x 0)
            (vec-dynamic x 0 (vector-length x) h)
            (when (and (get-hash-table h x #f)
                       (fxzero? (get-hash-table h x #f)))
              (put-hash-table! h x #f))])])) 
    (if (print-graph) 
        (graph x h)
        (dynamic x h)))
  
  (define (write-to-port x p)
    (let ([h (make-hash-table)])
      (hasher x h)
      (writer x p #t h 0))
    (flush-output-port p))
  
  (define (display-to-port x p)
    (let ([h (make-hash-table)])
      (hasher x h)
      (writer x p #f h 0))
    (flush-output-port p))
  
  (define formatter
    (lambda (who p fmt args)
      (let f ([i 0] [args args])
        (unless (fx= i (string-length fmt))
          (let ([c (string-ref fmt i)])
            (cond
              [($char= c #\~)
               (let ([i (fxadd1 i)])
                 (when (fx= i (string-length fmt))
                   (error who "invalid ~~ at end of format string ~s" fmt))
                 (let ([c (string-ref fmt i)])
                  (cond
                    [($char= c #\~) 
                     (write-char #\~ p)
                     (f (fxadd1 i) args)]
                    [($char= c #\%) 
                     (write-char #\newline p)
                     (f (fxadd1 i) args)] 
                    [($char= c #\a)
                     (when (null? args)
                       (error who "insufficient arguments"))
                     (display-to-port (car args) p)
                     (f (fxadd1 i) (cdr args))]
                    [($char= c #\s)
                     (when (null? args)
                       (error who "insufficient arguments"))
                     (write-to-port (car args) p)
                     (f (fxadd1 i) (cdr args))]
                    [else
                     (error who "invalid sequence ~~~a" c)])))]
              [else 
               (write-char c p)
               (f (fxadd1 i) args)]))))
      (flush-output-port p)))
  
  (define fprintf
    (lambda (port fmt . args)
      (unless (output-port? port) 
        (error 'fprintf "~s is not an output port" port))
      (unless (string? fmt)
        (error 'fprintf "~s is not a string" fmt))
      (formatter 'fprintf port fmt args)))

  (define display-error
    (lambda (errname who fmt args)
      (unless (string? fmt)
        (error 'print-error "~s is 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)
        (error 'format "~s is not a string" fmt))
      (let ([p (open-output-string)])
        (formatter 'format p fmt args)
        (get-output-string p))))
   
  (define printf 
    (lambda (fmt . args)
      (unless (string? fmt)
        (error 'printf "~s is 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)
       (unless (output-port? p) 
         (error 'write "~s is not an output port" p))
       (write-to-port x p)]))

  (define display 
    (case-lambda
      [(x) (display-to-port x (current-output-port))]
      [(x p)
       (unless (output-port? p) 
         (error 'display "~s is not an output port" p))
       (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 error-handler
    (make-parameter
      (lambda args
        (apply print-error args)
        (flush-output-port (console-output-port))
        (exit -1))
      (lambda (x)
        (if (procedure? x)
            x
            (error 'error-handler "~s is not a procedure" x)))))

  (define error
    (lambda args
      (apply (error-handler) args))))