1#!/usr/local/bin/sketchy -f 2 3; PP.SCM -- A pretty-printer for SketchyLISP. 4; Copyright (C) 2006,2007 Nils M Holm <nmh@t3x.org> 5; See the file LICENSE for conditions of use. 6 7; ---name--- 8; pp 9 10; ---purpose--- 11; Pretty-print SketchyLISP (and some Scheme) programs. 12; .P 13; .E Because PP uses 14; .C read 15; .E to parse expressions, it strips all comments 16; .E from its input programs. 17 18; ---language--- 19; R5RS Scheme 20 21; ---keywords--- 22; Pretty-printing, code, formatting, reformatting. 23 24; ---example--- 25; (pp '(let ((a 1) (b 2)) (lambda (x) (list x a b)))) => #<void> 26; ; Output: 27; ; (let ((a 1) 28; ; (b 2)) 29; ; (lambda (x) 30; ; (list x a b))) 31 32; (require "lib/not.scm") 33; (require "lib/s-length.scm") ; string-length 34; (require "lib/numtostr.scm") ; number->string 35; (require "lib/ceqp.scm") ; char=? 36; (require "lib/ceqp.scm") ; char=? 37; (require "lib/booleanp.scm") ; boolean? 38; (require "lib/zerop.scm") ; zero? 39; (require "lib/list.scm") 40; (require "lib/minus.scm") ; - 41; (require "lib/plus.scm") ; + 42; (require "lib/gteq.scm") ; >= 43; (require "lib/greater.scm") ; > 44; (require "lib/newline.scm") 45; (require "lib/less.scm") ; < 46; (require "lib/letstar.scm") ; let* 47; (require "lib/if.scm") 48; (require "lib/caar.scm") ; caar cadr cddr 49; (require "lib/caaar.scm") ; caddr cadar 50; (require "lib/caaaar.scm") ; cadddr 51; (require "lib/length.scm") 52 53; ---code--- 54(define Right-margin 72) 55 56(define LP #\() 57(define RP #\)) 58 59(define (atom? x) 60 (and (not (pair? x)) 61 (not (null? x)) 62 (not (vector? x)))) 63 64(define (pp-atom-length x) 65 (cond ((null? x) 2) 66 ((number? x) 67 (string-length (number->string x))) 68 ((string? x) 69 (+ 2 (string-length x))) 70 ((char? x) 71 (cond ((char=? x #\newline) 9) 72 ((char=? x #\space) 7) 73 (else 3))) 74 ((boolean? x) 2) 75 ((symbol? x) 76 (string-length (symbol->string x))) 77 (else (bottom (list 'unknown 'atom: x))))) 78 79(define (pp-list-length x) 80 (cond ((vector? x) 81 (+ 1 (pp-list-length (vector->list x)))) 82 ((not (pair? x)) 83 (pp-atom-length x)) 84 ((eq? (car x) 'quote) 85 (+ 1 (pp-list-length (cadr x)))) 86 (else (+ 1 (pp-list-length (car x)) 87 (let ((k (pp-list-length (cdr x)))) 88 (if (atom? (cdr x)) (+ 4 k) k)))))) 89 90(define (pp-length x) 91 (cond ((atom? x) (pp-atom-length x)) 92 (else (pp-list-length x)))) 93 94(define (spaces n) 95 (or (zero? n) 96 (begin (display #\space) 97 (spaces (- n 1))))) 98 99(define (pp-atom x) 100 (begin (write x) 101 (pp-atom-length x))) 102 103(define (exceeds-margin k x) 104 (>= (+ k (pp-length x)) 105 Right-margin)) 106 107(define (linewrap k x) 108 (cond ((zero? k) k) 109 ((exceeds-margin k x) 110 (begin (newline) 0)) 111 (else k))) 112 113(define (indent k n) 114 (cond ((not (zero? k)) k) 115 ((< k n) (begin (spaces (- n k)) n)) 116 (else k))) 117 118(define (pp-members x n k) 119 (cond ((null? x) k) 120 ((not (pair? x)) 121 (begin (display ". ") 122 (+ 2 k (pp-atom x)))) 123 (else (let* ((k (pp-expr (car x) (+ 2 n) k #f)) 124 (k (cond ((null? (cdr x)) k) 125 ((> k 0) (begin (display #\space) 126 (+ 1 k))) 127 (else 0)))) 128 (pp-members (cdr x) n k))))) 129 130(define (pp-list x n k glue) 131 (let* ((k (if glue k (linewrap k x))) 132 (k (indent k n))) 133 (cond ((not (pair? x)) 134 (+ k (pp-atom x))) 135 (else (begin (display LP) 136 (let ((k (pp-members x k (+ 1 k)))) 137 (begin (display RP) 138 (+ 1 k)))))))) 139 140(define (pp-quote x n k) 141 (begin (display #\') 142 (pp-expr (cadr x) n (+ 1 k) #t))) 143 144(define (pp-lambda x n k) 145 (begin (display LP) 146 (display "lambda ") 147 (pp-expr (cadr x) (+ 2 k) (+ 8 k) #t) 148 (newline) 149 (let ((k (pp-expr (caddr x) (+ 2 k) 0 #f))) 150 (begin (display RP) 151 (+ 1 k))))) 152 153(define (pp-cond x n k) 154 (letrec 155 ((pp-indented-clause 156 (lambda (x n k) 157 (begin (display LP) 158 (pp-expr (caar x) n (+ 1 k) #t) 159 (newline) 160 (let ((k (pp-expr (cadar x) (+ 2 n) 0 #f))) 161 (begin (display RP) 162 (+ 1 k)))))) 163 (pp-inline-clause 164 (lambda (x n k) 165 (begin (display LP) 166 (let ((k (pp-expr (caar x) n (+ 1 k) #t))) 167 (begin (display #\space) 168 (let ((k (pp-expr (cadar x) 169 (+ 1 k) (+ 1 k) #t))) 170 (begin (display RP) 171 (+ 1 k)))))))) 172 (pp-clause 173 (lambda (x n k) 174 (let ((k (indent k n))) 175 (cond ((and (exceeds-margin k (car x)) 176 (not (eq? (caar x) #t)) 177 (not (eq? (caar x) 'else))) 178 (pp-indented-clause x n k)) 179 (else (pp-inline-clause x n k)))))) 180 (indent-clauses 181 (lambda (x n k) 182 (let ((k (pp-clause x n k))) 183 (cond ((null? (cdr x)) 184 (begin (display RP) 185 (+ 1 k))) 186 (else (begin (newline) 187 (indent-clauses (cdr x) n 0)))))))) 188 (begin (display LP) 189 (display "cond ") 190 (indent-clauses (cdr x) (+ k 2) (+ k 6))))) 191 192(define (pp-if x n k) 193 (cond ((exceeds-margin k x) 194 (begin (display LP) 195 (display "if ") 196 (pp-expr (cadr x) (+ 4 n) (+ 4 k) #t) 197 (newline) 198 (pp-expr (caddr x) (+ 4 n) 0 #f) 199 (newline) 200 (let ((k (pp-expr (cadddr x) (+ 4 n) 0 #f))) 201 (begin (display RP) 202 (+ 1 k))))) 203 (else (pp-list x n k #t)))) 204 205(define (pp-indented x n k prefix always-split) 206 (let ((pl (+ 1 (string-length prefix)))) 207 (letrec 208 ((indent-args 209 (lambda (x n k glue) 210 (let ((k (pp-expr (car x) n k glue))) 211 (cond ((null? (cdr x)) 212 (begin (display RP) 213 (+ 1 k))) 214 (else (begin (newline) 215 (indent-args (cdr x) n 0 #f)))))))) 216 (cond ((or (and (> (length x) 1) (exceeds-margin k x)) 217 always-split) 218 (begin (display LP) 219 (display prefix) 220 (indent-args (cdr x) (+ k pl) (+ k pl) #t))) 221 (else (pp-list x (+ k pl) k #f)))))) 222 223(define (pp-and x n k) 224 (pp-indented x n k "and " #f)) 225 226(define (pp-or x n k) 227 (pp-indented x n k "or " #f)) 228 229(define (pp-begin x n k) 230 (pp-indented x n k "begin " #t)) 231 232(define (pp-let-body x n k ind) 233 (letrec 234 ((lambda? 235 (lambda (x) 236 (and (pair? x) (eq? 'lambda (car x))))) 237 (pp-let-procedure 238 (lambda (x n k) 239 (begin (pp-expr (caar x) n (+ 1 k) #t) 240 (newline) 241 (let ((k (pp-expr (cadar x) (+ 2 n) 0 #t))) 242 (begin (display RP) 243 (+ 2 k)))))) 244 (pp-let-data 245 (lambda (x n k) 246 (let ((k (pp-expr (caar x) n (+ 1 k) #t))) 247 (begin (display #\space) 248 (let ((k (pp-expr (cadar x) (+ 2 n) (+ 1 k) #t))) 249 (begin (display RP) 250 (+ 2 k))))))) 251 (pp-assoc 252 (lambda (x n k) 253 (let ((k (indent k n))) 254 (begin (display LP) 255 (cond ((lambda? (cadar x)) 256 (pp-let-procedure x n k)) 257 (else (pp-let-data x n k))))))) 258 (indent-bindings 259 (lambda (x n k) 260 (let ((k (pp-assoc x n k))) 261 (cond ((null? (cdr x)) 262 (begin (display RP) 263 (+ 1 k))) 264 (else (begin (newline) 265 (indent-bindings (cdr x) n 0)))))))) 266 (let ((k (indent-bindings (cadr x) (+ n ind) k))) 267 (begin (newline) 268 (let ((k (pp-expr (caddr x) (+ 2 n) 0 #f))) 269 (begin (display RP) 270 (+ 2 k))))))) 271 272(define (pp-let x n k) 273 (begin (display LP) 274 (display "let ") 275 (display LP) 276 (pp-let-body x k (+ 6 k) 6))) 277 278(define (pp-let* x n k) 279 (begin (display LP) 280 (display "let* ") 281 (display LP) 282 (pp-let-body x k (+ 7 k) 7))) 283 284(define (pp-letrec x n k) 285 (begin (display LP) 286 (display "letrec ") 287 (newline) 288 (let ((k (indent 0 (+ k 2)))) 289 (begin (display LP) 290 (pp-let-body x n (+ 1 k) 3))))) 291 292(define (pp-define x n k) 293 (cond ((pair? (cadr x)) 294 (begin (display LP) 295 (display "define ") 296 (pp-list (cadr x) n k #t) 297 (newline) 298 (let ((k (pp-expr (caddr x) (+ 2 n) 0 #f))) 299 (begin (display RP) 300 (+ 1 k))))) 301 (else (pp-list x n k #f)))) 302 303(define (pp-define-syntax x n k) 304 (begin (display LP) 305 (display "define-syntax ") 306 (pp-list (cadr x) n k #t) 307 (newline) 308 (let ((k (pp-expr (caddr x) (+ 2 k) 0 #f))) 309 (begin (display RP) 310 (+ 1 k))))) 311 312(define (pp-syntax-rules x n k) 313 (letrec 314 ((pp-rules 315 (lambda (x n k) 316 (cond ((null? x) k) 317 (else (begin (indent 0 n) 318 (display LP) 319 (pp-list (caar x) n (+ 1 k) #t) 320 (newline) 321 (let* ((k (pp-list (cadar x) (+ 2 n) 0 #f))) 322 (cond ((null? (cdr x)) 323 (begin (display RP) 324 (pp-rules (cdr x) n k))) 325 (else (begin (newline) 326 (pp-rules (cdr x) n 0))))))))))) 327 (begin (display LP) 328 (display "syntax-rules ") 329 (pp-list (cadr x) (+ 16 k) (+ 14 k) #t) 330 (newline) 331 (let ((k (pp-rules (cddr x) (+ 2 k) (+ 2 n k)))) 332 (begin (display RP) 333 (+ 2 k)))))) 334 335(define (pp-expr x n k glue) 336 (let* ((k (if glue k (linewrap k x))) 337 (k (indent k n))) 338 (cond ((vector? x) 339 (begin (display "#") 340 (display LP) 341 (let ((k (pp-members (vector->list x) n (+ 2 k)))) 342 (begin (display RP) 343 (+ 2 k))))) 344 ((not (pair? x)) (+ k (pp-atom x))) 345 ((eq? (car x) 'quote) (pp-quote x n k)) 346 ((eq? (car x) 'lambda) (pp-lambda x n k)) 347 ((eq? (car x) 'cond) (pp-cond x n k)) 348 ((eq? (car x) 'if) (pp-if x n k)) 349 ((eq? (car x) 'and) (pp-and x n k)) 350 ((eq? (car x) 'or) (pp-or x n k)) 351 ((eq? (car x) 'let) (pp-let x n k)) 352 ((eq? (car x) 'let*) (pp-let* x n k)) 353 ((eq? (car x) 'letrec) (pp-letrec x n k)) 354 ((eq? (car x) 'begin) (pp-begin x n k)) 355 ((eq? (car x) 'define) (pp-define x n k)) 356 ((eq? (car x) 'define-syntax) (pp-define-syntax x n k)) 357 ((eq? (car x) 'syntax-rules) (pp-syntax-rules x n k)) 358 (else (begin (display LP) 359 (let ((k (pp-members x n (+ 1 k)))) 360 (begin (display RP) 361 (+ 1 k)))))))) 362 363(define (pp x) 364 (begin (pp-expr x 0 0 #f) 365 (newline))) 366 367(define (main) 368 (letrec 369 ((pp* 370 (lambda (x) 371 (and (not (eof-object? x)) 372 (begin (pp x) 373 (let ((next (read))) 374 (begin (cond ((not (eof-object? next)) 375 (newline)) 376 (else #f)) 377 (pp* next)))))))) 378 (pp* (read)))) 379