SketchyLISP Stuff | Copyright (C) 2007 Nils M Holm |
[ More Sketchy LISP Stuff ] |
Language: R5RS Scheme
Purpose:
Pretty-print SketchyLISP (and some Scheme) programs.
Because PP uses
read
to parse expressions, it strips all comments
from its input programs.
Implementation:
(define Right-margin 72) (define LP #\() (define RP #\)) (define (atom? x) (and (not (pair? x)) (not (null? x)) (not (vector? x)))) (define (pp-atom-length x) (cond ((null? x) 2) ((number? x) (string-length (number->string x))) ((string? x) (+ 2 (string-length x))) ((char? x) (cond ((char=? x #\newline) 9) ((char=? x #\space) 7) (else 3))) ((boolean? x) 2) ((symbol? x) (string-length (symbol->string x))) (else (bottom (list 'unknown 'atom: x))))) (define (pp-list-length x) (cond ((vector? x) (+ 1 (pp-list-length (vector->list x)))) ((not (pair? x)) (pp-atom-length x)) ((eq? (car x) 'quote) (+ 1 (pp-list-length (cadr x)))) (else (+ 1 (pp-list-length (car x)) (let ((k (pp-list-length (cdr x)))) (if (atom? (cdr x)) (+ 4 k) k)))))) (define (pp-length x) (cond ((atom? x) (pp-atom-length x)) (else (pp-list-length x)))) (define (spaces n) (or (zero? n) (begin (display #\space) (spaces (- n 1))))) (define (pp-atom x) (begin (write x) (pp-atom-length x))) (define (exceeds-margin k x) (>= (+ k (pp-length x)) Right-margin)) (define (linewrap k x) (cond ((zero? k) k) ((exceeds-margin k x) (begin (newline) 0)) (else k))) (define (indent k n) (cond ((not (zero? k)) k) ((< k n) (begin (spaces (- n k)) n)) (else k))) (define (pp-members x n k) (cond ((null? x) k) ((not (pair? x)) (begin (display ". ") (+ 2 k (pp-atom x)))) (else (let* ((k (pp-expr (car x) (+ 2 n) k #f)) (k (cond ((null? (cdr x)) k) ((> k 0) (begin (display #\space) (+ 1 k))) (else 0)))) (pp-members (cdr x) n k))))) (define (pp-list x n k glue) (let* ((k (if glue k (linewrap k x))) (k (indent k n))) (cond ((not (pair? x)) (+ k (pp-atom x))) (else (begin (display LP) (let ((k (pp-members x k (+ 1 k)))) (begin (display RP) (+ 1 k)))))))) (define (pp-quote x n k) (begin (display #\') (pp-expr (cadr x) n (+ 1 k) #t))) (define (pp-lambda x n k) (begin (display LP) (display "lambda ") (pp-expr (cadr x) (+ 2 k) (+ 8 k) #t) (newline) (let ((k (pp-expr (caddr x) (+ 2 k) 0 #f))) (begin (display RP) (+ 1 k))))) (define (pp-cond x n k) (letrec ((pp-indented-clause (lambda (x n k) (begin (display LP) (pp-expr (caar x) n (+ 1 k) #t) (newline) (let ((k (pp-expr (cadar x) (+ 2 n) 0 #f))) (begin (display RP) (+ 1 k)))))) (pp-inline-clause (lambda (x n k) (begin (display LP) (let ((k (pp-expr (caar x) n (+ 1 k) #t))) (begin (display #\space) (let ((k (pp-expr (cadar x) (+ 1 k) (+ 1 k) #t))) (begin (display RP) (+ 1 k)))))))) (pp-clause (lambda (x n k) (let ((k (indent k n))) (cond ((and (exceeds-margin k (car x)) (not (eq? (caar x) #t)) (not (eq? (caar x) 'else))) (pp-indented-clause x n k)) (else (pp-inline-clause x n k)))))) (indent-clauses (lambda (x n k) (let ((k (pp-clause x n k))) (cond ((null? (cdr x)) (begin (display RP) (+ 1 k))) (else (begin (newline) (indent-clauses (cdr x) n 0)))))))) (begin (display LP) (display "cond ") (indent-clauses (cdr x) (+ k 2) (+ k 6))))) (define (pp-if x n k) (cond ((exceeds-margin k x) (begin (display LP) (display "if ") (pp-expr (cadr x) (+ 4 n) (+ 4 k) #t) (newline) (pp-expr (caddr x) (+ 4 n) 0 #f) (newline) (let ((k (pp-expr (cadddr x) (+ 4 n) 0 #f))) (begin (display RP) (+ 1 k))))) (else (pp-list x n k #t)))) (define (pp-indented x n k prefix always-split) (let ((pl (+ 1 (string-length prefix)))) (letrec ((indent-args (lambda (x n k glue) (let ((k (pp-expr (car x) n k glue))) (cond ((null? (cdr x)) (begin (display RP) (+ 1 k))) (else (begin (newline) (indent-args (cdr x) n 0 #f)))))))) (cond ((or (and (> (length x) 1) (exceeds-margin k x)) always-split) (begin (display LP) (display prefix) (indent-args (cdr x) (+ k pl) (+ k pl) #t))) (else (pp-list x (+ k pl) k #f)))))) (define (pp-and x n k) (pp-indented x n k "and " #f)) (define (pp-or x n k) (pp-indented x n k "or " #f)) (define (pp-begin x n k) (pp-indented x n k "begin " #t)) (define (pp-let-body x n k ind) (letrec ((lambda? (lambda (x) (and (pair? x) (eq? 'lambda (car x))))) (pp-let-procedure (lambda (x n k) (begin (pp-expr (caar x) n (+ 1 k) #t) (newline) (let ((k (pp-expr (cadar x) (+ 2 n) 0 #t))) (begin (display RP) (+ 2 k)))))) (pp-let-data (lambda (x n k) (let ((k (pp-expr (caar x) n (+ 1 k) #t))) (begin (display #\space) (let ((k (pp-expr (cadar x) (+ 2 n) (+ 1 k) #t))) (begin (display RP) (+ 2 k))))))) (pp-assoc (lambda (x n k) (let ((k (indent k n))) (begin (display LP) (cond ((lambda? (cadar x)) (pp-let-procedure x n k)) (else (pp-let-data x n k))))))) (indent-bindings (lambda (x n k) (let ((k (pp-assoc x n k))) (cond ((null? (cdr x)) (begin (display RP) (+ 1 k))) (else (begin (newline) (indent-bindings (cdr x) n 0)))))))) (let ((k (indent-bindings (cadr x) (+ n ind) k))) (begin (newline) (let ((k (pp-expr (caddr x) (+ 2 n) 0 #f))) (begin (display RP) (+ 2 k))))))) (define (pp-let x n k) (begin (display LP) (display "let ") (display LP) (pp-let-body x k (+ 6 k) 6))) (define (pp-let* x n k) (begin (display LP) (display "let* ") (display LP) (pp-let-body x k (+ 7 k) 7))) (define (pp-letrec x n k) (begin (display LP) (display "letrec ") (newline) (let ((k (indent 0 (+ k 2)))) (begin (display LP) (pp-let-body x n (+ 1 k) 3))))) (define (pp-define x n k) (cond ((pair? (cadr x)) (begin (display LP) (display "define ") (pp-list (cadr x) n k #t) (newline) (let ((k (pp-expr (caddr x) (+ 2 n) 0 #f))) (begin (display RP) (+ 1 k))))) (else (pp-list x n k #f)))) (define (pp-define-syntax x n k) (begin (display LP) (display "define-syntax ") (pp-list (cadr x) n k #t) (newline) (let ((k (pp-expr (caddr x) (+ 2 k) 0 #f))) (begin (display RP) (+ 1 k))))) (define (pp-syntax-rules x n k) (letrec ((pp-rules (lambda (x n k) (cond ((null? x) k) (else (begin (indent 0 n) (display LP) (pp-list (caar x) n (+ 1 k) #t) (newline) (let* ((k (pp-list (cadar x) (+ 2 n) 0 #f))) (cond ((null? (cdr x)) (begin (display RP) (pp-rules (cdr x) n k))) (else (begin (newline) (pp-rules (cdr x) n 0))))))))))) (begin (display LP) (display "syntax-rules ") (pp-list (cadr x) (+ 16 k) (+ 14 k) #t) (newline) (let ((k (pp-rules (cddr x) (+ 2 k) (+ 2 n k)))) (begin (display RP) (+ 2 k)))))) (define (pp-expr x n k glue) (let* ((k (if glue k (linewrap k x))) (k (indent k n))) (cond ((vector? x) (begin (display "#") (display LP) (let ((k (pp-members (vector->list x) n (+ 2 k)))) (begin (display RP) (+ 2 k))))) ((not (pair? x)) (+ k (pp-atom x))) ((eq? (car x) 'quote) (pp-quote x n k)) ((eq? (car x) 'lambda) (pp-lambda x n k)) ((eq? (car x) 'cond) (pp-cond x n k)) ((eq? (car x) 'if) (pp-if x n k)) ((eq? (car x) 'and) (pp-and x n k)) ((eq? (car x) 'or) (pp-or x n k)) ((eq? (car x) 'let) (pp-let x n k)) ((eq? (car x) 'let*) (pp-let* x n k)) ((eq? (car x) 'letrec) (pp-letrec x n k)) ((eq? (car x) 'begin) (pp-begin x n k)) ((eq? (car x) 'define) (pp-define x n k)) ((eq? (car x) 'define-syntax) (pp-define-syntax x n k)) ((eq? (car x) 'syntax-rules) (pp-syntax-rules x n k)) (else (begin (display LP) (let ((k (pp-members x n (+ 1 k)))) (begin (display RP) (+ 1 k)))))))) (define (pp x) (begin (pp-expr x 0 0 #f) (newline))) (define (main) (letrec ((pp* (lambda (x) (and (not (eof-object? x)) (begin (pp x) (let ((next (read))) (begin (cond ((not (eof-object? next)) (newline)) (else #f)) (pp* next)))))))) (pp* (read))))
Example:
(pp '(let ((a 1) (b 2)) (lambda (x) (list x a b)))) => #<void> ; Output: ; (let ((a 1) ; (b 2)) ; (lambda (x) ; (list x a b)))
[ More Sketchy LISP Stuff ] |