scheme code formatter (as in kyotolisp #1, see slideshare.net)

format.scm

(define-method object-pp-like-list? (x) #f)
(define-method object-pp-like-list? ((x <pair>)) #t)
(define-method object-pp-like-list? ((x <vector>)) #t)
;(define-method object-pp-like-list? ((x <sequence>)) #t)
(define-method object-pp-like-list? ((x <string>)) #f)
(define-method object-pp-x->list ((x <pair>)) x)
(define-method object-pp-x->list ((x <vector>)) (vector->list x))
;(define-method object-pp-x->list ((x <sequence>)) (map values x))
(define-method object-pp-left-paren (x) (format "(#~a " (class-name (class-of x))))
(define-method object-pp-left-paren ((x <vector>)) "#(")
(define-method object-pp-left-paren ((x <pair>)) "(")
(define-method object-pp-right-paren (x) ")")
(define-method object-pp-heavy? (x) #f)

(define (pp expr)
  (define tabstop 2)
  (define (newline-indent level) (newline) (dotimes (n level) (whitespace)))
  (define (whitespace) (display " "))
  (define (heavy? expr)
    (cond
      ((pair? expr) 
        (cond
          ((and (eq? (car expr) 'quote)           (pair? (cdr expr)) (null? (cddr expr))) (heavy? (cadr expr)))
          ((and (eq? (car expr) 'quasiquote)      (pair? (cdr expr)) (null? (cddr expr))) (heavy? (cadr expr)))
          ((and (eq? (car expr) 'unquote)         (pair? (cdr expr)) (null? (cddr expr))) (heavy? (cadr expr)))
          ((and (eq? (car expr) 'unquote-splicing)(pair? (cdr expr)) (null? (cddr expr))) (heavy? (cadr expr)))
          ; r6rs
          ;((syntax-quote)            (display "#'")  (loop level (cadr expr)))
          ;((syntax-quasiquote)       (display "#`")  (loop level (cadr expr)))
          ;((syntax-unquote)          (display "#,")  (loop level (cadr expr)))
          ;((syntax-unquote-splicing) (display "#,@") (loop level (cadr expr)))
          (else #t)))
      ((vector? expr) #t)
      ((string? expr) (< 30 (string-length expr)))
      (else (object-pp-heavy? expr))))
  (define (very-heavy? expr)
    (cond
      ((pair? expr)
        (or
          (any
            (lambda (x)
              (and (object-pp-like-list? x)
                (any heavy? (dotted->proper (object-pp-x->list x)))))
            (dotted->proper expr))
          (< 20 (length expr))))
      (else #f)))
  (define (dotted->proper maybe-dotted)
    (let loop ((expr maybe-dotted))
      (cond
        ((pair? expr)
          (cons (car expr) (loop (cdr expr))))
        ((null? expr) '())
        (else (list expr)))))
  (let loop ((level tabstop) (expr expr))
    (cond
      ((pair? expr) ; code
        (cond
          ((and (eq? (car expr) 'quote)            (pair? (cdr expr)) (null? (cddr expr))) (display "'")  (loop level (cadr expr)))
          ((and (eq? (car expr) 'quasiquote)       (pair? (cdr expr)) (null? (cddr expr))) (display "`")  (loop level (cadr expr)))
          ((and (eq? (car expr) 'unquote)          (pair? (cdr expr)) (null? (cddr expr))) (display ",")  (loop level (cadr expr)))
          ((and (eq? (car expr) 'unquote-splicing) (pair? (cdr expr)) (null? (cddr expr))) (display ",@") (loop level (cadr expr)))
          ; r6rs
          ;((syntax-quote)            (display "#'")  (loop level (cadr expr)))
          ;((syntax-quasiquote)       (display "#`")  (loop level (cadr expr)))
          ;((syntax-unquote)          (display "#,")  (loop level (cadr expr)))
          ;((syntax-unquote-splicing) (display "#,@") (loop level (cadr expr)))
          (else
            (display "(")
            (loop (+ level tabstop) (car expr))
            (case (car expr)
              ((if set! case when call-with-input-file call-with-output-file with-input-from-file with-output-to-file shift receive)
                (when
                  (and
                    (pair? (cdr expr))
                    (or
                      (not (list? (cadr expr)))
                      (not (very-heavy? (cadr expr)))))
                  (whitespace)
                  (write (cadr expr))
                  (set! expr (cdr expr))))
              ((define lambda)
                  (whitespace)
                  (write (cadr expr))
                  (set! expr (cdr expr)))
              ((define-method)
                  (whitespace)
                  (write (cadr expr))
                  (whitespace)
                  (write (caddr expr))
                  (set! expr (cddr expr)))
              ((let let* letrec)
                (cond
                  ((and
                    (pair? (cdr expr))
                    (list? (cadr expr))
                    (not (any very-heavy? (cadr expr)))
                    (< (length (cadr expr)) 4))
                    (whitespace)
                    (write (cadr expr))
                    (set! expr (cdr expr)))
                  ((and
                    (pair? (cdr expr))
                    (symbol? (cadr expr))
                    (pair? (cddr expr))
                    (list? (caddr expr))
                    (not (any very-heavy? (caddr expr)))
                    (< (length (caddr expr)) 4))
                    (whitespace)
                    (write (cadr expr))
                    (whitespace)
                    (write (caddr expr))
                    (set! expr (cddr expr))))))
            (let ((newline? (very-heavy? expr)))
               (let loop2 ((e (cdr expr)))
                 (cond
                   ((null? e))
                   ((and (pair? e) (null? (cdr e)))
                     (if newline? (newline-indent level) (whitespace))
                     (loop (+ level tabstop) (car e)))
                   ((pair? e)
                     (if newline? (newline-indent level) (whitespace))
                     (loop (+ level tabstop) (car e))
                     (loop2 (cdr e)))
                   (else
                     (if newline? (newline-indent level) (whitespace))
                     (display ". ")
                     (loop (+ level tabstop) e)))))
            (display ")"))))
      ((object-pp-like-list? expr)
        (display (object-pp-left-paren expr))
        (let ((expr (object-pp-x->list expr)))
          (loop (+ level tabstop) (car expr))
          (let ((newline? (very-heavy? expr)))
             (let loop2 ((e (cdr expr)))
               (cond
                 ((null? e))
                 ((and (pair? e) (null? (cdr e)))
                   (if newline? (newline-indent level) (whitespace))
                   (loop (+ level tabstop) (car e)))
                 ((pair? e)
                   (if newline? (newline-indent level) (whitespace))
                   (loop (+ level tabstop) (car e))
                   (loop2 (cdr e)))
                 (else
                   (if newline? (newline-indent level) (whitespace))
                   (display ". ")
                   (loop (+ level tabstop) e))))))
        (display (object-pp-right-paren expr)))
      (else (write expr))))
  (newline))

scheme code formatter (as in kyotolisp#1, see slideshare.net)

(define-method object-pp-like-list? (x) #f)
(define-method object-pp-like-list? ((x <pair>)) #t)
(define-method object-pp-like-list? ((x <vector>)) #t)
;(define-method object-pp-like-list? ((x <sequence>)) #t)
(define-method object-pp-like-list? ((x <string>)) #f)
(define-method object-pp-x->list ((x <pair>)) x)
(define-method object-pp-x->list ((x <vector>)) (vector->list x))
;(define-method object-pp-x->list ((x <sequence>)) (map values x))
(define-method object-pp-left-paren (x) (format "(#~a " (class-name (class-of x))))
(define-method object-pp-left-paren ((x <vector>)) "#(")
(define-method object-pp-left-paren ((x <pair>)) "(")
(define-method object-pp-right-paren (x) ")")
(define-method object-pp-heavy? (x) #f)

(define (pp expr)
  (define tabstop 2)
  (define (newline-indent level) (newline) (dotimes (n level) (whitespace)))
  (define (whitespace) (display " "))
  (define (heavy? expr)
    (cond
      ((pair? expr) 
        (cond
          ((and (eq? (car expr) 'quote)           (pair? (cdr expr)) (null? (cddr expr))) (heavy? (cadr expr)))
          ((and (eq? (car expr) 'quasiquote)      (pair? (cdr expr)) (null? (cddr expr))) (heavy? (cadr expr)))
          ((and (eq? (car expr) 'unquote)         (pair? (cdr expr)) (null? (cddr expr))) (heavy? (cadr expr)))
          ((and (eq? (car expr) 'unquote-splicing)(pair? (cdr expr)) (null? (cddr expr))) (heavy? (cadr expr)))
          ; r6rs
          ;((syntax-quote)            (display "#'")  (loop level (cadr expr)))
          ;((syntax-quasiquote)       (display "#`")  (loop level (cadr expr)))
          ;((syntax-unquote)          (display "#,")  (loop level (cadr expr)))
          ;((syntax-unquote-splicing) (display "#,@") (loop level (cadr expr)))
          (else #t)))
      ((vector? expr) #t)
      ((string? expr) (< 30 (string-length expr)))
      (else (object-pp-heavy? expr))))
  (define (very-heavy? expr)
    (cond
      ((pair? expr)
        (or
          (any
            (lambda (x)
              (and (object-pp-like-list? x)
                (any heavy? (dotted->proper (object-pp-x->list x)))))
            (dotted->proper expr))
          (< 20 (length expr))))
      (else #f)))
  (define (dotted->proper maybe-dotted)
    (let loop ((expr maybe-dotted))
      (cond
        ((pair? expr)
          (cons (car expr) (loop (cdr expr))))
        ((null? expr) '())
        (else (list expr)))))
  (let loop ((level tabstop) (expr expr))
    (cond
      ((pair? expr) ; code
        (cond
          ((and (eq? (car expr) 'quote)            (pair? (cdr expr)) (null? (cddr expr))) (display "'")  (loop level (cadr expr)))
          ((and (eq? (car expr) 'quasiquote)       (pair? (cdr expr)) (null? (cddr expr))) (display "`")  (loop level (cadr expr)))
          ((and (eq? (car expr) 'unquote)          (pair? (cdr expr)) (null? (cddr expr))) (display ",")  (loop level (cadr expr)))
          ((and (eq? (car expr) 'unquote-splicing) (pair? (cdr expr)) (null? (cddr expr))) (display ",@") (loop level (cadr expr)))
          ; r6rs
          ;((syntax-quote)            (display "#'")  (loop level (cadr expr)))
          ;((syntax-quasiquote)       (display "#`")  (loop level (cadr expr)))
          ;((syntax-unquote)          (display "#,")  (loop level (cadr expr)))
          ;((syntax-unquote-splicing) (display "#,@") (loop level (cadr expr)))
          (else
            (display "(")
            (loop (+ level tabstop) (car expr))
            (case (car expr)
              ((if set! case when call-with-input-file call-with-output-file with-input-from-file with-output-to-file shift receive)
                (when
                  (and
                    (pair? (cdr expr))
                    (or
                      (not (list? (cadr expr)))
                      (not (very-heavy? (cadr expr)))))
                  (whitespace)
                  (write (cadr expr))
                  (set! expr (cdr expr))))
              ((define lambda)
                  (whitespace)
                  (write (cadr expr))
                  (set! expr (cdr expr)))
              ((define-method)
                  (whitespace)
                  (write (cadr expr))
                  (whitespace)
                  (write (caddr expr))
                  (set! expr (cddr expr)))
              ((let let* letrec)
                (cond
                  ((and
                    (pair? (cdr expr))
                    (list? (cadr expr))
                    (not (any very-heavy? (cadr expr)))
                    (< (length (cadr expr)) 4))
                    (whitespace)
                    (write (cadr expr))
                    (set! expr (cdr expr)))
                  ((and
                    (pair? (cdr expr))
                    (symbol? (cadr expr))
                    (pair? (cddr expr))
                    (list? (caddr expr))
                    (not (any very-heavy? (caddr expr)))
                    (< (length (caddr expr)) 4))
                    (whitespace)
                    (write (cadr expr))
                    (whitespace)
                    (write (caddr expr))
                    (set! expr (cddr expr))))))
            (let ((newline? (very-heavy? expr)))
               (let loop2 ((e (cdr expr)))
                 (cond
                   ((null? e))
                   ((and (pair? e) (null? (cdr e)))
                     (if newline? (newline-indent level) (whitespace))
                     (loop (+ level tabstop) (car e)))
                   ((pair? e)
                     (if newline? (newline-indent level) (whitespace))
                     (loop (+ level tabstop) (car e))
                     (loop2 (cdr e)))
                   (else
                     (if newline? (newline-indent level) (whitespace))
                     (display ". ")
                     (loop (+ level tabstop) e)))))
            (display ")"))))
      ((object-pp-like-list? expr)
        (display (object-pp-left-paren expr))
        (let ((expr (object-pp-x->list expr)))
          (loop (+ level tabstop) (car expr))
          (let ((newline? (very-heavy? expr)))
             (let loop2 ((e (cdr expr)))
               (cond
                 ((null? e))
                 ((and (pair? e) (null? (cdr e)))
                   (if newline? (newline-indent level) (whitespace))
                   (loop (+ level tabstop) (car e)))
                 ((pair? e)
                   (if newline? (newline-indent level) (whitespace))
                   (loop (+ level tabstop) (car e))
                   (loop2 (cdr e)))
                 (else
                   (if newline? (newline-indent level) (whitespace))
                   (display ". ")
                   (loop (+ level tabstop) e))))))
        (display (object-pp-right-paren expr)))
      (else (write expr))))
  (newline))