Artifact
e1835ecd75e48717ad6c9b147973f8eb52c4528c:
- File
fmt/fmt-pretty.scm
— part of check-in
[80c8c83034]
at
2016-07-07 18:11:39
on branch trunk
— initial import
(user:
ovenpasta@pizzahack.eu
size: 9018)
0000: 3b 3b 3b 3b 20 66 6d 74 2d 70 72 65 74 74 79 2e ;;;; fmt-pretty.
0010: 73 63 6d 20 2d 2d 20 70 72 65 74 74 79 20 70 72 scm -- pretty pr
0020: 69 6e 74 69 6e 67 20 66 6f 72 6d 61 74 20 63 6f inting format co
0030: 6d 62 69 6e 61 74 6f 72 0a 3b 3b 0a 3b 3b 20 43 mbinator.;;.;; C
0040: 6f 70 79 72 69 67 68 74 20 28 63 29 20 32 30 30 opyright (c) 200
0050: 36 2d 32 30 30 37 20 41 6c 65 78 20 53 68 69 6e 6-2007 Alex Shin
0060: 6e 2e 20 20 41 6c 6c 20 72 69 67 68 74 73 20 72 n. All rights r
0070: 65 73 65 72 76 65 64 2e 0a 3b 3b 20 42 53 44 2d eserved..;; BSD-
0080: 73 74 79 6c 65 20 6c 69 63 65 6e 73 65 3a 20 68 style license: h
0090: 74 74 70 3a 2f 2f 73 79 6e 74 68 63 6f 64 65 2e ttp://synthcode.
00a0: 63 6f 6d 2f 6c 69 63 65 6e 73 65 2e 74 78 74 0a com/license.txt.
00b0: 0a 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b .;;;;;;;;;;;;;;;
00c0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
00d0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
00e0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
00f0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 3b 3b 3b 20 61 64 ;;;;;;;;;.;;; ad
0100: 64 69 74 69 6f 6e 61 6c 20 73 65 74 74 69 6e 67 ditional setting
0110: 73 0a 0a 28 64 65 66 69 6e 65 20 28 66 6d 74 2d s..(define (fmt-
0120: 73 68 61 72 65 73 20 73 74 29 20 28 66 6d 74 2d shares st) (fmt-
0130: 72 65 66 20 73 74 20 27 73 68 61 72 65 73 29 29 ref st 'shares))
0140: 0a 28 64 65 66 69 6e 65 20 28 66 6d 74 2d 73 65 .(define (fmt-se
0150: 74 2d 73 68 61 72 65 73 21 20 73 74 20 78 29 20 t-shares! st x)
0160: 28 66 6d 74 2d 73 65 74 21 20 73 74 20 27 73 68 (fmt-set! st 'sh
0170: 61 72 65 73 20 78 29 29 0a 28 64 65 66 69 6e 65 ares x)).(define
0180: 20 28 66 6d 74 2d 63 6f 70 79 2d 73 68 61 72 65 (fmt-copy-share
0190: 73 20 73 74 29 0a 20 20 28 66 6d 74 2d 73 65 74 s st). (fmt-set
01a0: 2d 73 68 61 72 65 73 21 20 28 63 6f 70 79 2d 66 -shares! (copy-f
01b0: 6d 74 2d 73 74 61 74 65 20 73 74 29 20 28 63 6f mt-state st) (co
01c0: 70 79 2d 73 68 61 72 65 73 20 28 66 6d 74 2d 73 py-shares (fmt-s
01d0: 68 61 72 65 73 20 73 74 29 29 29 29 0a 0a 28 64 hares st))))..(d
01e0: 65 66 69 6e 65 20 28 63 6f 70 79 2d 73 68 61 72 efine (copy-shar
01f0: 65 73 20 73 68 61 72 65 73 29 0a 20 20 28 6c 65 es shares). (le
0200: 74 20 28 28 74 61 62 20 28 6d 61 6b 65 2d 65 71 t ((tab (make-eq
0210: 3f 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 28 ?-table))). (
0220: 68 61 73 68 2d 74 61 62 6c 65 2d 77 61 6c 6b 0a hash-table-walk.
0230: 20 20 20 20 20 28 63 61 72 20 73 68 61 72 65 73 (car shares
0240: 29 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 ). (lambda (
0250: 6f 62 6a 20 78 29 20 28 65 71 3f 2d 74 61 62 6c obj x) (eq?-tabl
0260: 65 2d 73 65 74 21 20 74 61 62 20 6f 62 6a 20 28 e-set! tab obj (
0270: 63 6f 6e 73 20 28 63 61 72 20 78 29 20 28 63 64 cons (car x) (cd
0280: 72 20 78 29 29 29 29 29 0a 20 20 20 20 28 63 6f r x))))). (co
0290: 6e 73 20 74 61 62 20 28 63 64 72 20 73 68 61 72 ns tab (cdr shar
02a0: 65 73 29 29 29 29 0a 0a 3b 3b 3b 3b 3b 3b 3b 3b es))))..;;;;;;;;
02b0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
02c0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
02d0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
02e0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
02f0: 0a 3b 3b 3b 20 75 74 69 6c 69 74 69 65 73 0a 0a .;;; utilities..
0300: 28 64 65 66 69 6e 65 20 28 66 6d 74 2d 73 68 61 (define (fmt-sha
0310: 72 65 64 2d 77 72 69 74 65 20 6f 62 6a 20 70 72 red-write obj pr
0320: 6f 63 29 0a 20 20 28 6c 61 6d 62 64 61 20 28 73 oc). (lambda (s
0330: 74 29 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 73 t). (let* ((s
0340: 68 61 72 65 73 20 28 66 6d 74 2d 73 68 61 72 65 hares (fmt-share
0350: 73 20 73 74 29 29 0a 20 20 20 20 20 20 20 20 20 s st)).
0360: 20 20 28 63 65 6c 6c 20 28 61 6e 64 20 73 68 61 (cell (and sha
0370: 72 65 73 20 28 65 71 3f 2d 74 61 62 6c 65 2d 72 res (eq?-table-r
0380: 65 66 20 28 63 61 72 20 73 68 61 72 65 73 29 20 ef (car shares)
0390: 6f 62 6a 29 29 29 29 0a 20 20 20 20 20 20 28 69 obj)))). (i
03a0: 66 20 28 70 61 69 72 3f 20 63 65 6c 6c 29 0a 20 f (pair? cell).
03b0: 20 20 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 (cond.
03c0: 20 20 20 20 20 20 20 20 20 20 20 28 28 63 64 72 ((cdr
03d0: 20 63 65 6c 6c 29 0a 20 20 20 20 20 20 20 20 20 cell).
03e0: 20 20 20 20 28 28 66 6d 74 2d 77 72 69 74 65 72 ((fmt-writer
03f0: 20 73 74 29 20 28 67 65 6e 2d 73 68 61 72 65 64 st) (gen-shared
0400: 2d 72 65 66 20 28 63 61 72 20 63 65 6c 6c 29 20 -ref (car cell)
0410: 22 23 22 29 20 73 74 29 29 0a 20 20 20 20 20 20 "#") st)).
0420: 20 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 (else.
0430: 20 20 20 20 20 20 20 20 20 28 73 65 74 2d 63 61 (set-ca
0440: 72 21 20 63 65 6c 6c 20 28 63 64 72 20 73 68 61 r! cell (cdr sha
0450: 72 65 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 res)).
0460: 20 20 20 28 73 65 74 2d 63 64 72 21 20 63 65 6c (set-cdr! cel
0470: 6c 20 23 74 29 0a 20 20 20 20 20 20 20 20 20 20 l #t).
0480: 20 20 20 28 73 65 74 2d 63 64 72 21 20 73 68 61 (set-cdr! sha
0490: 72 65 73 20 28 2b 20 28 63 64 72 20 73 68 61 72 res (+ (cdr shar
04a0: 65 73 29 20 31 29 29 0a 20 20 20 20 20 20 20 20 es) 1)).
04b0: 20 20 20 20 20 28 70 72 6f 63 20 28 28 66 6d 74 (proc ((fmt
04c0: 2d 77 72 69 74 65 72 20 73 74 29 20 28 67 65 6e -writer st) (gen
04d0: 2d 73 68 61 72 65 64 2d 72 65 66 20 28 63 61 72 -shared-ref (car
04e0: 20 63 65 6c 6c 29 20 22 3d 22 29 20 73 74 29 29 cell) "=") st))
04f0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 70 72 )). (pr
0500: 6f 63 20 73 74 29 29 29 29 29 0a 0a 28 64 65 66 oc st)))))..(def
0510: 69 6e 65 20 28 66 6d 74 2d 6a 6f 69 6e 2f 73 68 ine (fmt-join/sh
0520: 61 72 65 73 20 66 6d 74 20 6c 73 20 2e 20 6f 29 ares fmt ls . o)
0530: 0a 20 20 28 6c 65 74 20 28 28 73 65 70 20 28 64 . (let ((sep (d
0540: 73 70 20 28 69 66 20 28 70 61 69 72 3f 20 6f 29 sp (if (pair? o)
0550: 20 28 63 61 72 20 6f 29 20 22 20 22 29 29 29 29 (car o) " "))))
0560: 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 73 74 . (lambda (st
0570: 29 0a 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c ). (if (nul
0580: 6c 3f 20 6c 73 29 0a 20 20 20 20 20 20 20 20 20 l? ls).
0590: 20 73 74 0a 20 20 20 20 20 20 20 20 20 20 28 6c st. (l
05a0: 65 74 2a 20 28 28 73 68 61 72 65 73 20 28 66 6d et* ((shares (fm
05b0: 74 2d 73 68 61 72 65 73 20 73 74 29 29 0a 20 20 t-shares st)).
05c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
05d0: 74 61 62 20 28 63 61 72 20 73 68 61 72 65 73 29 tab (car shares)
05e0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
05f0: 20 20 20 28 6f 75 74 70 75 74 20 28 66 6d 74 2d (output (fmt-
0600: 77 72 69 74 65 72 20 73 74 29 29 29 0a 20 20 20 writer st))).
0610: 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 6c 70 (let lp
0620: 20 28 28 6c 73 20 6c 73 29 20 28 73 74 20 73 74 ((ls ls) (st st
0630: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
0640: 20 28 6c 65 74 20 28 28 73 74 20 28 28 66 6d 74 (let ((st ((fmt
0650: 20 28 63 61 72 20 6c 73 29 29 20 73 74 29 29 0a (car ls)) st)).
0660: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0670: 20 20 20 20 28 72 65 73 74 20 28 63 64 72 20 6c (rest (cdr l
0680: 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 s))).
0690: 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 (cond.
06a0: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 6e 75 ((nu
06b0: 6c 6c 3f 20 72 65 73 74 29 20 73 74 29 0a 20 20 ll? rest) st).
06c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
06d0: 28 70 61 69 72 3f 20 72 65 73 74 29 0a 20 20 20 (pair? rest).
06e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
06f0: 63 61 6c 6c 2d 77 69 74 68 2d 73 68 61 72 65 64 call-with-shared
0700: 2d 72 65 66 2f 63 64 72 20 72 65 73 74 20 73 74 -ref/cdr rest st
0710: 20 73 68 61 72 65 73 0a 20 20 20 20 20 20 20 20 shares.
0720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
0730: 61 6d 62 64 61 20 28 73 74 29 20 28 6c 70 20 72 ambda (st) (lp r
0740: 65 73 74 20 73 74 29 29 0a 20 20 20 20 20 20 20 est st)).
0750: 20 20 20 20 20 20 20 20 20 20 20 20 20 73 65 70 sep
0760: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
0770: 20 20 20 20 28 65 6c 73 65 20 28 28 66 6d 74 20 (else ((fmt
0780: 72 65 73 74 29 20 28 6f 75 74 70 75 74 20 22 2e rest) (output ".
0790: 20 22 20 28 73 65 70 20 73 74 29 29 29 29 29 29 " (sep st))))))
07a0: 29 29 29 29 29 29 0a 0a 3b 3b 3b 3b 3b 3b 3b 3b ))))))..;;;;;;;;
07b0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
07c0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
07d0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
07e0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
07f0: 0a 3b 3b 3b 20 70 72 65 74 74 79 20 70 72 69 6e .;;; pretty prin
0800: 74 69 6e 67 0a 0a 28 64 65 66 69 6e 65 20 28 6e ting..(define (n
0810: 6f 6e 2d 61 70 70 3f 20 78 29 0a 20 20 28 69 66 on-app? x). (if
0820: 20 28 70 61 69 72 3f 20 78 29 0a 20 20 20 20 20 (pair? x).
0830: 20 28 6f 72 20 28 6e 6f 74 20 28 6f 72 20 28 6e (or (not (or (n
0840: 75 6c 6c 3f 20 28 63 64 72 20 78 29 29 20 28 70 ull? (cdr x)) (p
0850: 61 69 72 3f 20 28 63 64 72 20 78 29 29 29 29 0a air? (cdr x)))).
0860: 20 20 20 20 20 20 20 20 20 20 28 6e 6f 6e 2d 61 (non-a
0870: 70 70 3f 20 28 63 61 72 20 78 29 29 29 0a 20 20 pp? (car x))).
0880: 20 20 20 20 28 6e 6f 74 20 28 73 79 6d 62 6f 6c (not (symbol
0890: 3f 20 78 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 ? x))))..(define
08a0: 20 73 79 6e 74 61 78 2d 61 62 62 72 65 76 73 0a syntax-abbrevs.
08b0: 20 20 27 28 28 71 75 6f 74 65 20 2e 20 22 27 22 '((quote . "'"
08c0: 29 20 28 71 75 61 73 69 71 75 6f 74 65 20 2e 20 ) (quasiquote .
08d0: 22 60 22 29 20 28 75 6e 71 75 6f 74 65 20 2e 20 "`") (unquote .
08e0: 22 2c 22 29 20 28 75 6e 71 75 6f 74 65 2d 73 70 ",") (unquote-sp
08f0: 6c 69 63 69 6e 67 20 2e 20 22 2c 40 22 29 0a 20 licing . ",@").
0900: 20 20 20 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ))..(define (
0910: 70 70 2d 6c 65 74 20 6c 73 29 0a 20 20 28 69 66 pp-let ls). (if
0920: 20 28 61 6e 64 20 28 70 61 69 72 3f 20 28 63 64 (and (pair? (cd
0930: 72 20 6c 73 29 29 20 28 73 79 6d 62 6f 6c 3f 20 r ls)) (symbol?
0940: 28 63 61 64 72 20 6c 73 29 29 29 0a 20 20 20 20 (cadr ls))).
0950: 20 20 28 70 70 2d 77 69 74 68 2d 69 6e 64 65 6e (pp-with-inden
0960: 74 20 32 20 6c 73 29 0a 20 20 20 20 20 20 28 70 t 2 ls). (p
0970: 70 2d 77 69 74 68 2d 69 6e 64 65 6e 74 20 31 20 p-with-indent 1
0980: 6c 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 69 ls)))..(define i
0990: 6e 64 65 6e 74 2d 72 75 6c 65 73 0a 20 20 60 28 ndent-rules. `(
09a0: 28 6c 61 6d 62 64 61 20 2e 20 31 29 20 28 64 65 (lambda . 1) (de
09b0: 66 69 6e 65 20 2e 20 31 29 0a 20 20 20 20 28 6c fine . 1). (l
09c0: 65 74 20 2e 20 2c 70 70 2d 6c 65 74 29 20 28 6c et . ,pp-let) (l
09d0: 6f 6f 70 20 2e 20 2c 70 70 2d 6c 65 74 29 0a 20 oop . ,pp-let).
09e0: 20 20 20 28 6c 65 74 2a 20 2e 20 31 29 20 28 6c (let* . 1) (l
09f0: 65 74 72 65 63 20 2e 20 31 29 20 28 6c 65 74 72 etrec . 1) (letr
0a00: 65 63 2a 20 2e 20 31 29 20 28 61 6e 64 2d 6c 65 ec* . 1) (and-le
0a10: 74 2a 20 2e 20 31 29 20 28 6c 65 74 31 20 2e 20 t* . 1) (let1 .
0a20: 32 29 0a 20 20 20 20 28 6c 65 74 2d 76 61 6c 75 2). (let-valu
0a30: 65 73 20 2e 20 31 29 20 28 6c 65 74 2a 2d 76 61 es . 1) (let*-va
0a40: 6c 75 65 73 20 2e 20 31 29 20 28 72 65 63 65 69 lues . 1) (recei
0a50: 76 65 20 2e 20 32 29 20 28 70 61 72 61 6d 65 74 ve . 2) (paramet
0a60: 65 72 69 7a 65 20 2e 20 31 29 0a 20 20 20 20 28 erize . 1). (
0a70: 6c 65 74 2d 73 79 6e 74 61 78 20 2e 20 31 29 20 let-syntax . 1)
0a80: 28 6c 65 74 72 65 63 2d 73 79 6e 74 61 78 20 2e (letrec-syntax .
0a90: 20 31 29 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 1) (syntax-rule
0aa0: 73 20 2e 20 31 29 20 28 73 79 6e 74 61 78 2d 63 s . 1) (syntax-c
0ab0: 61 73 65 20 2e 20 32 29 0a 20 20 20 20 28 6d 61 ase . 2). (ma
0ac0: 74 63 68 20 2e 20 31 29 20 28 6d 61 74 63 68 2d tch . 1) (match-
0ad0: 6c 65 74 20 2e 20 31 29 20 28 6d 61 74 63 68 2d let . 1) (match-
0ae0: 6c 65 74 2a 20 2e 20 31 29 0a 20 20 20 20 28 69 let* . 1). (i
0af0: 66 20 2e 20 33 29 20 28 77 68 65 6e 20 2e 20 31 f . 3) (when . 1
0b00: 29 20 28 75 6e 6c 65 73 73 20 2e 20 31 29 20 28 ) (unless . 1) (
0b10: 63 61 73 65 20 2e 20 31 29 20 28 77 68 69 6c 65 case . 1) (while
0b20: 20 2e 20 31 29 20 28 75 6e 74 69 6c 20 2e 20 31 . 1) (until . 1
0b30: 29 0a 20 20 20 20 28 64 6f 20 2e 20 32 29 20 28 ). (do . 2) (
0b40: 64 6f 74 69 6d 65 73 20 2e 20 31 29 20 28 64 6f dotimes . 1) (do
0b50: 6c 69 73 74 20 2e 20 31 29 20 28 74 65 73 74 20 list . 1) (test
0b60: 2e 20 31 29 0a 20 20 20 20 28 63 6f 6e 64 69 74 . 1). (condit
0b70: 69 6f 6e 2d 63 61 73 65 20 2e 20 31 29 20 28 67 ion-case . 1) (g
0b80: 75 61 72 64 20 2e 20 31 29 20 28 72 65 63 20 2e uard . 1) (rec .
0b90: 20 31 29 0a 20 20 20 20 28 63 61 6c 6c 2d 77 69 1). (call-wi
0ba0: 74 68 2d 63 75 72 72 65 6e 74 2d 63 6f 6e 74 69 th-current-conti
0bb0: 6e 75 61 74 69 6f 6e 20 2e 20 30 29 0a 20 20 20 nuation . 0).
0bc0: 20 29 29 0a 0a 28 64 65 66 69 6e 65 20 69 6e 64 ))..(define ind
0bd0: 65 6e 74 2d 70 72 65 66 69 78 2d 72 75 6c 65 73 ent-prefix-rules
0be0: 0a 20 20 60 28 28 22 77 69 74 68 2d 22 20 2e 20 . `(("with-" .
0bf0: 2d 31 29 20 28 22 63 61 6c 6c 2d 77 69 74 68 2d -1) ("call-with-
0c00: 22 20 2e 20 2d 31 29 20 28 22 64 65 66 69 6e 65 " . -1) ("define
0c10: 2d 22 20 2e 20 31 29 29 0a 20 20 29 0a 0a 28 64 -" . 1)). )..(d
0c20: 65 66 69 6e 65 20 69 6e 64 65 6e 74 2d 73 75 66 efine indent-suf
0c30: 66 69 78 2d 72 75 6c 65 73 0a 20 20 60 28 28 22 fix-rules. `(("
0c40: 2d 63 61 73 65 22 20 2e 20 31 29 29 0a 20 20 29 -case" . 1)). )
0c50: 0a 0a 28 64 65 66 69 6e 65 20 28 70 70 2d 69 6e ..(define (pp-in
0c60: 64 65 6e 74 61 74 69 6f 6e 20 66 6f 72 6d 29 0a dentation form).
0c70: 20 20 28 6c 65 74 20 28 28 69 6e 64 65 6e 74 0a (let ((indent.
0c80: 20 20 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 (cond.
0c90: 20 20 20 20 20 20 20 20 20 28 28 61 73 73 71 20 ((assq
0ca0: 28 63 61 72 20 66 6f 72 6d 29 20 69 6e 64 65 6e (car form) inden
0cb0: 74 2d 72 75 6c 65 73 29 20 3d 3e 20 63 64 72 29 t-rules) => cdr)
0cc0: 0a 20 20 20 20 20 20 20 20 20 20 28 28 61 6e 64 . ((and
0cd0: 20 28 73 79 6d 62 6f 6c 3f 20 28 63 61 72 20 66 (symbol? (car f
0ce0: 6f 72 6d 29 29 0a 20 20 20 20 20 20 20 20 20 20 orm)).
0cf0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 73 74 72 (let ((str
0d00: 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 (symbol->string
0d10: 20 28 63 61 72 20 66 6f 72 6d 29 29 29 29 0a 20 (car form)))).
0d20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0d30: 20 28 6f 72 20 28 66 69 6e 64 20 28 6c 61 6d 62 (or (find (lamb
0d40: 64 61 20 28 72 78 29 20 28 73 74 72 69 6e 67 2d da (rx) (string-
0d50: 70 72 65 66 69 78 3f 20 28 63 61 72 20 72 78 29 prefix? (car rx)
0d60: 20 73 74 72 29 29 0a 20 20 20 20 20 20 20 20 20 str)).
0d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0d80: 20 20 20 69 6e 64 65 6e 74 2d 70 72 65 66 69 78 indent-prefix
0d90: 2d 72 75 6c 65 73 29 0a 20 20 20 20 20 20 20 20 -rules).
0da0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 66 (f
0db0: 69 6e 64 20 28 6c 61 6d 62 64 61 20 28 72 78 29 ind (lambda (rx)
0dc0: 20 28 73 74 72 69 6e 67 2d 73 75 66 66 69 78 3f (string-suffix?
0dd0: 20 28 63 61 72 20 72 78 29 20 73 74 72 29 29 0a (car rx) str)).
0de0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0df0: 20 20 20 20 20 20 20 20 20 20 20 20 69 6e 64 65 inde
0e00: 6e 74 2d 73 75 66 66 69 78 2d 72 75 6c 65 73 29 nt-suffix-rules)
0e10: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 3d ))). =
0e20: 3e 20 63 64 72 29 0a 20 20 20 20 20 20 20 20 20 > cdr).
0e30: 20 28 65 6c 73 65 20 23 66 29 29 29 29 0a 20 20 (else #f)))).
0e40: 20 20 28 69 66 20 28 61 6e 64 20 28 6e 75 6d 62 (if (and (numb
0e50: 65 72 3f 20 69 6e 64 65 6e 74 29 20 28 6e 65 67 er? indent) (neg
0e60: 61 74 69 76 65 3f 20 69 6e 64 65 6e 74 29 29 0a ative? indent)).
0e70: 20 20 20 20 20 20 20 20 28 6d 61 78 20 30 20 28 (max 0 (
0e80: 2d 20 28 2b 20 28 6c 65 6e 67 74 68 2b 20 66 6f - (+ (length+ fo
0e90: 72 6d 29 20 69 6e 64 65 6e 74 29 20 31 29 29 0a rm) indent) 1)).
0ea0: 20 20 20 20 20 20 20 20 69 6e 64 65 6e 74 29 29 indent))
0eb0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 70 70 2d 77 )..(define (pp-w
0ec0: 69 74 68 2d 69 6e 64 65 6e 74 20 69 6e 64 65 6e ith-indent inden
0ed0: 74 2d 72 75 6c 65 20 6c 73 29 0a 20 20 28 6c 61 t-rule ls). (la
0ee0: 6d 62 64 61 20 28 73 74 29 0a 20 20 20 20 28 6c mbda (st). (l
0ef0: 65 74 2a 20 28 28 63 6f 6c 31 20 28 66 6d 74 2d et* ((col1 (fmt-
0f00: 63 6f 6c 20 73 74 29 29 0a 20 20 20 20 20 20 20 col st)).
0f10: 20 20 20 20 28 73 74 20 28 28 63 61 74 20 22 28 (st ((cat "(
0f20: 22 20 28 70 70 2d 6f 62 6a 65 63 74 20 28 63 61 " (pp-object (ca
0f30: 72 20 6c 73 29 29 29 20 73 74 29 29 0a 20 20 20 r ls))) st)).
0f40: 20 20 20 20 20 20 20 20 28 63 6f 6c 32 20 28 66 (col2 (f
0f50: 6d 74 2d 63 6f 6c 20 73 74 29 29 0a 20 20 20 20 mt-col st)).
0f60: 20 20 20 20 20 20 20 28 66 69 78 65 64 20 28 74 (fixed (t
0f70: 61 6b 65 2a 20 28 63 64 72 20 6c 73 29 20 28 6f ake* (cdr ls) (o
0f80: 72 20 69 6e 64 65 6e 74 2d 72 75 6c 65 20 31 29 r indent-rule 1)
0f90: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 74 )). (t
0fa0: 61 69 6c 20 28 64 72 6f 70 2a 20 28 63 64 72 20 ail (drop* (cdr
0fb0: 6c 73 29 20 28 6f 72 20 69 6e 64 65 6e 74 2d 72 ls) (or indent-r
0fc0: 75 6c 65 20 31 29 29 29 0a 20 20 20 20 20 20 20 ule 1))).
0fd0: 20 20 20 20 28 73 74 32 20 28 66 6d 74 2d 63 6f (st2 (fmt-co
0fe0: 70 79 2d 73 68 61 72 65 73 20 73 74 29 29 0a 20 py-shares st)).
0ff0: 20 20 20 20 20 20 20 20 20 20 28 66 69 72 73 74 (first
1000: 2d 6c 69 6e 65 0a 20 20 20 20 20 20 20 20 20 20 -line.
1010: 20 20 28 28 66 6d 74 2d 74 6f 2d 73 74 72 69 6e ((fmt-to-strin
1020: 67 20 28 63 61 74 20 22 20 22 20 28 66 6d 74 2d g (cat " " (fmt-
1030: 6a 6f 69 6e 2f 73 68 61 72 65 73 20 70 70 2d 66 join/shares pp-f
1040: 6c 61 74 20 66 69 78 65 64 20 22 20 22 29 29 29 lat fixed " ")))
1050: 20 73 74 32 29 29 0a 20 20 20 20 20 20 20 20 20 st2)).
1060: 20 20 28 64 65 66 61 75 6c 74 0a 20 20 20 20 20 (default.
1070: 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 73 (let ((s
1080: 65 70 20 28 6d 61 6b 65 2d 6e 6c 2d 73 70 61 63 ep (make-nl-spac
1090: 65 20 28 2b 20 63 6f 6c 31 20 31 29 29 29 29 0a e (+ col1 1)))).
10a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
10b0: 63 61 74 20 73 65 70 20 28 66 6d 74 2d 6a 6f 69 cat sep (fmt-joi
10c0: 6e 2f 73 68 61 72 65 73 20 70 70 2d 6f 62 6a 65 n/shares pp-obje
10d0: 63 74 20 28 63 64 72 20 6c 73 29 20 73 65 70 29 ct (cdr ls) sep)
10e0: 20 22 29 22 29 29 29 29 0a 20 20 20 20 20 20 28 ")")))). (
10f0: 63 6f 6e 64 0a 20 20 20 20 20 20 20 28 28 3c 20 cond. ((<
1100: 28 2b 20 63 6f 6c 32 20 28 73 74 72 69 6e 67 2d (+ col2 (string-
1110: 6c 65 6e 67 74 68 20 66 69 72 73 74 2d 6c 69 6e length first-lin
1120: 65 29 29 20 28 66 6d 74 2d 77 69 64 74 68 20 73 e)) (fmt-width s
1130: 74 32 29 29 0a 20 20 20 20 20 20 20 20 3b 3b 20 t2)). ;;
1140: 66 69 78 65 64 20 76 61 6c 75 65 73 20 6f 6e 20 fixed values on
1150: 66 69 72 73 74 20 6c 69 6e 65 0a 20 20 20 20 20 first line.
1160: 20 20 20 28 6c 65 74 20 28 28 73 65 70 20 28 6d (let ((sep (m
1170: 61 6b 65 2d 6e 6c 2d 73 70 61 63 65 0a 20 20 20 ake-nl-space.
1180: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1190: 20 28 69 66 20 69 6e 64 65 6e 74 2d 72 75 6c 65 (if indent-rule
11a0: 20 28 2b 20 63 6f 6c 31 20 32 29 20 28 2b 20 63 (+ col1 2) (+ c
11b0: 6f 6c 32 20 31 29 29 29 29 29 0a 20 20 20 20 20 ol2 1))))).
11c0: 20 20 20 20 20 28 28 63 61 74 20 66 69 72 73 74 ((cat first
11d0: 2d 6c 69 6e 65 0a 20 20 20 20 20 20 20 20 20 20 -line.
11e0: 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 (cond.
11f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 6e ((n
1200: 6f 74 20 28 6f 72 20 28 6e 75 6c 6c 3f 20 74 61 ot (or (null? ta
1210: 69 6c 29 20 28 70 61 69 72 3f 20 74 61 69 6c 29 il) (pair? tail)
1220: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
1230: 20 20 20 20 20 28 63 61 74 20 22 2e 20 22 20 28 (cat ". " (
1240: 70 70 2d 6f 62 6a 65 63 74 20 74 61 69 6c 29 29 pp-object tail))
1250: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
1260: 20 20 20 28 28 3e 20 28 6c 65 6e 67 74 68 2b 20 ((> (length+
1270: 28 63 64 72 20 6c 73 29 29 20 28 6f 72 20 69 6e (cdr ls)) (or in
1280: 64 65 6e 74 2d 72 75 6c 65 20 31 29 29 0a 20 20 dent-rule 1)).
1290: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12a0: 28 63 61 74 20 73 65 70 20 28 66 6d 74 2d 6a 6f (cat sep (fmt-jo
12b0: 69 6e 2f 73 68 61 72 65 73 20 70 70 2d 6f 62 6a in/shares pp-obj
12c0: 65 63 74 20 74 61 69 6c 20 73 65 70 29 29 29 0a ect tail sep))).
12d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12e0: 20 28 65 6c 73 65 0a 20 20 20 20 20 20 20 20 20 (else.
12f0: 20 20 20 20 20 20 20 20 20 66 6d 74 2d 6e 75 6c fmt-nul
1300: 6c 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 l)).
1310: 20 20 20 20 22 29 22 29 0a 20 20 20 20 20 20 20 ")").
1320: 20 20 20 20 73 74 32 29 29 29 0a 20 20 20 20 20 st2))).
1330: 20 20 28 69 6e 64 65 6e 74 2d 72 75 6c 65 20 3b (indent-rule ;
1340: 3b 28 61 6e 64 20 69 6e 64 65 6e 74 2d 72 75 6c ;(and indent-rul
1350: 65 20 28 6e 6f 74 20 28 70 61 69 72 3f 20 28 63 e (not (pair? (c
1360: 61 72 20 6c 73 29 29 29 29 0a 20 20 20 20 20 20 ar ls)))).
1370: 20 20 3b 3b 20 66 69 78 65 64 20 76 61 6c 75 65 ;; fixed value
1380: 73 20 6c 69 6e 65 64 20 75 70 2c 20 62 6f 64 79 s lined up, body
1390: 20 69 6e 64 65 6e 74 65 64 20 74 77 6f 20 73 70 indented two sp
13a0: 61 63 65 73 0a 20 20 20 20 20 20 20 20 28 28 66 aces. ((f
13b0: 6d 74 2d 74 72 79 2d 66 69 74 0a 20 20 20 20 20 mt-try-fit.
13c0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 73 74 (lambda (st
13d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 28 ). ((
13e0: 63 61 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 cat.
13f0: 20 20 22 20 22 0a 20 20 20 20 20 20 20 20 20 20 " ".
1400: 20 20 20 20 28 66 6d 74 2d 6a 6f 69 6e 2f 73 68 (fmt-join/sh
1410: 61 72 65 73 20 70 70 2d 6f 62 6a 65 63 74 20 66 ares pp-object f
1420: 69 78 65 64 20 28 6d 61 6b 65 2d 6e 6c 2d 73 70 ixed (make-nl-sp
1430: 61 63 65 20 28 2b 20 63 6f 6c 32 20 31 29 29 29 ace (+ col2 1)))
1440: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
1450: 69 66 20 28 70 61 69 72 3f 20 74 61 69 6c 29 0a if (pair? tail).
1460: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1470: 20 20 28 6c 65 74 20 28 28 73 65 70 20 28 6d 61 (let ((sep (ma
1480: 6b 65 2d 6e 6c 2d 73 70 61 63 65 20 28 2b 20 63 ke-nl-space (+ c
1490: 6f 6c 31 20 32 29 29 29 29 0a 20 20 20 20 20 20 ol1 2)))).
14a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
14b0: 61 74 20 73 65 70 20 28 66 6d 74 2d 6a 6f 69 6e at sep (fmt-join
14c0: 2f 73 68 61 72 65 73 20 70 70 2d 6f 62 6a 65 63 /shares pp-objec
14d0: 74 20 74 61 69 6c 20 73 65 70 29 29 29 0a 20 20 t tail sep))).
14e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14f0: 22 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 "").
1500: 20 20 22 29 22 29 0a 20 20 20 20 20 20 20 20 20 ")").
1510: 20 20 20 20 28 66 6d 74 2d 63 6f 70 79 2d 73 68 (fmt-copy-sh
1520: 61 72 65 73 20 73 74 29 29 29 0a 20 20 20 20 20 ares st))).
1530: 20 20 20 20 20 64 65 66 61 75 6c 74 29 0a 20 20 default).
1540: 20 20 20 20 20 20 20 73 74 29 29 0a 20 20 20 20 st)).
1550: 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 20 20 (else.
1560: 20 3b 3b 20 61 6c 6c 20 6f 6e 20 73 65 70 61 72 ;; all on separ
1570: 61 74 65 20 6c 69 6e 65 73 0a 20 20 20 20 20 20 ate lines.
1580: 20 20 28 64 65 66 61 75 6c 74 20 73 74 29 29 29 (default st)))
1590: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 70 70 )))..(define (pp
15a0: 2d 61 70 70 20 6c 73 29 0a 20 20 28 6c 65 74 20 -app ls). (let
15b0: 28 28 69 6e 64 65 6e 74 2d 72 75 6c 65 20 28 70 ((indent-rule (p
15c0: 70 2d 69 6e 64 65 6e 74 61 74 69 6f 6e 20 6c 73 p-indentation ls
15d0: 29 29 29 0a 20 20 20 20 28 69 66 20 28 70 72 6f ))). (if (pro
15e0: 63 65 64 75 72 65 3f 20 69 6e 64 65 6e 74 2d 72 cedure? indent-r
15f0: 75 6c 65 29 0a 20 20 20 20 20 20 20 20 28 69 6e ule). (in
1600: 64 65 6e 74 2d 72 75 6c 65 20 6c 73 29 0a 20 20 dent-rule ls).
1610: 20 20 20 20 20 20 28 70 70 2d 77 69 74 68 2d 69 (pp-with-i
1620: 6e 64 65 6e 74 20 69 6e 64 65 6e 74 2d 72 75 6c ndent indent-rul
1630: 65 20 6c 73 29 29 29 29 0a 0a 3b 3b 20 74 68 65 e ls))))..;; the
1640: 20 65 6c 65 6d 65 6e 74 73 20 6d 61 79 20 62 65 elements may be
1650: 20 73 68 61 72 65 64 2c 20 6a 75 73 74 20 63 68 shared, just ch
1660: 65 63 6b 69 6e 67 20 74 68 65 20 74 6f 70 20 6c ecking the top l
1670: 65 76 65 6c 20 6c 69 73 74 0a 3b 3b 20 73 74 72 evel list.;; str
1680: 75 63 74 75 72 65 0a 28 64 65 66 69 6e 65 20 28 ucture.(define (
1690: 70 72 6f 70 65 72 2d 6e 6f 6e 2d 73 68 61 72 65 proper-non-share
16a0: 64 2d 6c 69 73 74 3f 20 6c 73 20 73 68 61 72 65 d-list? ls share
16b0: 73 29 0a 20 20 28 6c 65 74 20 28 28 74 61 62 20 s). (let ((tab
16c0: 28 63 61 72 20 73 68 61 72 65 73 29 29 29 0a 20 (car shares))).
16d0: 20 20 20 28 6c 65 74 20 6c 70 20 28 28 6c 73 20 (let lp ((ls
16e0: 6c 73 29 29 0a 20 20 20 20 20 20 28 6f 72 20 28 ls)). (or (
16f0: 6e 75 6c 6c 3f 20 6c 73 29 0a 20 20 20 20 20 20 null? ls).
1700: 20 20 20 20 28 61 6e 64 20 28 70 61 69 72 3f 20 (and (pair?
1710: 6c 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ls).
1720: 20 20 20 28 6e 6f 74 20 28 65 71 3f 2d 74 61 62 (not (eq?-tab
1730: 6c 65 2d 72 65 66 20 74 61 62 20 6c 73 29 29 0a le-ref tab ls)).
1740: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
1750: 6c 70 20 28 63 64 72 20 6c 73 29 29 29 29 29 29 lp (cdr ls))))))
1760: 29 0a 0a 28 64 65 66 69 6e 65 20 28 70 70 2d 66 )..(define (pp-f
1770: 6c 61 74 20 78 29 0a 20 20 28 63 6f 6e 64 0a 20 lat x). (cond.
1780: 20 20 20 28 28 70 61 69 72 3f 20 78 29 0a 20 20 ((pair? x).
1790: 20 20 20 28 66 6d 74 2d 73 68 61 72 65 64 2d 77 (fmt-shared-w
17a0: 72 69 74 65 0a 20 20 20 20 20 20 78 0a 20 20 20 rite. x.
17b0: 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 (cond.
17c0: 20 28 28 61 6e 64 20 28 70 61 69 72 3f 20 28 63 ((and (pair? (c
17d0: 64 72 20 78 29 29 20 28 6e 75 6c 6c 3f 20 28 63 dr x)) (null? (c
17e0: 64 64 72 20 78 29 29 0a 20 20 20 20 20 20 20 20 ddr x)).
17f0: 20 20 20 20 20 20 28 61 73 73 71 20 28 63 61 72 (assq (car
1800: 20 78 29 20 73 79 6e 74 61 78 2d 61 62 62 72 65 x) syntax-abbre
1810: 76 73 29 29 0a 20 20 20 20 20 20 20 20 20 3d 3e vs)). =>
1820: 20 28 6c 61 6d 62 64 61 20 28 61 62 62 72 65 76 (lambda (abbrev
1830: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
1840: 28 63 61 74 20 28 63 64 72 20 61 62 62 72 65 76 (cat (cdr abbrev
1850: 29 20 28 70 70 2d 66 6c 61 74 20 28 63 61 64 72 ) (pp-flat (cadr
1860: 20 78 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 x))))).
1870: 28 65 6c 73 65 0a 20 20 20 20 20 20 20 20 20 28 (else. (
1880: 63 61 74 20 22 28 22 20 28 66 6d 74 2d 6a 6f 69 cat "(" (fmt-joi
1890: 6e 2f 73 68 61 72 65 73 20 70 70 2d 66 6c 61 74 n/shares pp-flat
18a0: 20 78 20 22 20 22 29 20 22 29 22 29 29 29 29 29 x " ") ")")))))
18b0: 0a 20 20 20 20 28 28 76 65 63 74 6f 72 3f 20 78 . ((vector? x
18c0: 29 0a 20 20 20 20 20 28 66 6d 74 2d 73 68 61 72 ). (fmt-shar
18d0: 65 64 2d 77 72 69 74 65 0a 20 20 20 20 20 20 78 ed-write. x
18e0: 0a 20 20 20 20 20 20 28 63 61 74 20 22 23 28 22 . (cat "#("
18f0: 20 28 66 6d 74 2d 6a 6f 69 6e 2f 73 68 61 72 65 (fmt-join/share
1900: 73 20 70 70 2d 66 6c 61 74 20 28 76 65 63 74 6f s pp-flat (vecto
1910: 72 2d 3e 6c 69 73 74 20 78 29 20 22 20 22 29 20 r->list x) " ")
1920: 22 29 22 29 29 29 0a 20 20 20 20 28 65 6c 73 65 ")"))). (else
1930: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 73 . (lambda (s
1940: 74 29 20 28 28 77 72 69 74 65 2d 77 69 74 68 2d t) ((write-with-
1950: 73 68 61 72 65 73 20 78 20 28 66 6d 74 2d 73 68 shares x (fmt-sh
1960: 61 72 65 73 20 73 74 29 29 20 73 74 29 29 29 29 ares st)) st))))
1970: 29 0a 0a 28 64 65 66 69 6e 65 20 28 70 70 2d 70 )..(define (pp-p
1980: 61 69 72 20 6c 73 29 0a 20 20 28 66 6d 74 2d 73 air ls). (fmt-s
1990: 68 61 72 65 64 2d 77 72 69 74 65 0a 20 20 20 6c hared-write. l
19a0: 73 0a 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 3b s. (cond. ;
19b0: 3b 20 6f 6e 65 20 65 6c 65 6d 65 6e 74 20 6c 69 ; one element li
19c0: 73 74 2c 20 6e 6f 20 6c 69 6e 65 73 20 74 6f 20 st, no lines to
19d0: 62 72 65 61 6b 0a 20 20 20 20 28 28 6e 75 6c 6c break. ((null
19e0: 3f 20 28 63 64 72 20 6c 73 29 29 0a 20 20 20 20 ? (cdr ls)).
19f0: 20 28 63 61 74 20 22 28 22 20 28 70 70 2d 6f 62 (cat "(" (pp-ob
1a00: 6a 65 63 74 20 28 63 61 72 20 6c 73 29 29 20 22 ject (car ls)) "
1a10: 29 22 29 29 0a 20 20 20 20 3b 3b 20 71 75 6f 74 )")). ;; quot
1a20: 65 20 6f 72 20 6f 74 68 65 72 20 61 62 62 72 65 e or other abbre
1a30: 76 0a 20 20 20 20 28 28 61 6e 64 20 28 70 61 69 v. ((and (pai
1a40: 72 3f 20 28 63 64 72 20 6c 73 29 29 20 28 6e 75 r? (cdr ls)) (nu
1a50: 6c 6c 3f 20 28 63 64 64 72 20 6c 73 29 29 0a 20 ll? (cddr ls)).
1a60: 20 20 20 20 20 20 20 20 20 28 61 73 73 71 20 28 (assq (
1a70: 63 61 72 20 6c 73 29 20 73 79 6e 74 61 78 2d 61 car ls) syntax-a
1a80: 62 62 72 65 76 73 29 29 0a 20 20 20 20 20 3d 3e bbrevs)). =>
1a90: 20 28 6c 61 6d 62 64 61 20 28 61 62 62 72 65 76 (lambda (abbrev
1aa0: 29 0a 20 20 20 20 20 20 20 20 20 20 28 63 61 74 ). (cat
1ab0: 20 28 63 64 72 20 61 62 62 72 65 76 29 20 28 70 (cdr abbrev) (p
1ac0: 70 2d 6f 62 6a 65 63 74 20 28 63 61 64 72 20 6c p-object (cadr l
1ad0: 73 29 29 29 29 29 0a 20 20 20 20 28 65 6c 73 65 s))))). (else
1ae0: 0a 20 20 20 20 20 28 66 6d 74 2d 74 72 79 2d 66 . (fmt-try-f
1af0: 69 74 0a 20 20 20 20 20 20 28 6c 61 6d 62 64 61 it. (lambda
1b00: 20 28 73 74 29 20 28 28 70 70 2d 66 6c 61 74 20 (st) ((pp-flat
1b10: 6c 73 29 20 28 66 6d 74 2d 63 6f 70 79 2d 73 68 ls) (fmt-copy-sh
1b20: 61 72 65 73 20 73 74 29 29 29 0a 20 20 20 20 20 ares st))).
1b30: 20 28 6c 61 6d 62 64 61 20 28 73 74 29 0a 20 20 (lambda (st).
1b40: 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 (if (and (
1b50: 6e 6f 6e 2d 61 70 70 3f 20 6c 73 29 0a 20 20 20 non-app? ls).
1b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 (p
1b70: 72 6f 70 65 72 2d 6e 6f 6e 2d 73 68 61 72 65 64 roper-non-shared
1b80: 2d 6c 69 73 74 3f 20 6c 73 20 28 66 6d 74 2d 73 -list? ls (fmt-s
1b90: 68 61 72 65 73 20 73 74 29 29 29 0a 20 20 20 20 hares st))).
1ba0: 20 20 20 20 20 20 20 20 28 28 70 70 2d 64 61 74 ((pp-dat
1bb0: 61 2d 6c 69 73 74 20 6c 73 29 20 73 74 29 0a 20 a-list ls) st).
1bc0: 20 20 20 20 20 20 20 20 20 20 20 28 28 70 70 2d ((pp-
1bd0: 61 70 70 20 6c 73 29 20 73 74 29 29 29 29 29 29 app ls) st))))))
1be0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 70 70 2d ))..(define (pp-
1bf0: 64 61 74 61 2d 6c 69 73 74 20 6c 73 29 0a 20 20 data-list ls).
1c00: 28 6c 61 6d 62 64 61 20 28 73 74 29 0a 20 20 20 (lambda (st).
1c10: 20 28 6c 65 74 2a 20 28 28 6f 75 74 70 75 74 20 (let* ((output
1c20: 28 66 6d 74 2d 77 72 69 74 65 72 20 73 74 29 29 (fmt-writer st))
1c30: 0a 20 20 20 20 20 20 20 20 20 20 20 28 73 74 20 . (st
1c40: 28 6f 75 74 70 75 74 20 22 28 22 20 73 74 29 29 (output "(" st))
1c50: 0a 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6c . (col
1c60: 20 28 66 6d 74 2d 63 6f 6c 20 73 74 29 29 0a 20 (fmt-col st)).
1c70: 20 20 20 20 20 20 20 20 20 20 28 77 69 64 74 68 (width
1c80: 20 28 2d 20 28 66 6d 74 2d 77 69 64 74 68 20 73 (- (fmt-width s
1c90: 74 29 20 63 6f 6c 29 29 0a 20 20 20 20 20 20 20 t) col)).
1ca0: 20 20 20 20 28 73 74 32 20 28 66 6d 74 2d 63 6f (st2 (fmt-co
1cb0: 70 79 2d 73 68 61 72 65 73 20 73 74 29 29 29 0a py-shares st))).
1cc0: 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 (cond.
1cd0: 20 20 20 20 28 28 61 6e 64 20 28 70 61 69 72 3f ((and (pair?
1ce0: 20 28 63 64 72 20 6c 73 29 29 20 28 70 61 69 72 (cdr ls)) (pair
1cf0: 3f 20 28 63 64 64 72 20 6c 73 29 29 20 28 70 61 ? (cddr ls)) (pa
1d00: 69 72 3f 20 28 63 64 64 64 72 20 6c 73 29 29 0a ir? (cdddr ls)).
1d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 ((
1d20: 66 69 74 73 2d 69 6e 2d 63 6f 6c 75 6d 6e 73 20 fits-in-columns
1d30: 6c 73 20 70 70 2d 66 6c 61 74 20 77 69 64 74 68 ls pp-flat width
1d40: 29 20 73 74 32 29 29 0a 20 20 20 20 20 20 20 20 ) st2)).
1d50: 20 3d 3e 20 28 6c 61 6d 62 64 61 20 28 6c 73 29 => (lambda (ls)
1d60: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b . ;
1d70: 3b 20 61 74 20 6c 65 61 73 74 20 66 6f 75 72 20 ; at least four
1d80: 65 6c 65 6d 65 6e 74 73 20 77 68 69 63 68 20 63 elements which c
1d90: 61 6e 20 62 65 20 62 72 6f 6b 65 6e 20 69 6e 74 an be broken int
1da0: 6f 20 63 6f 6c 75 6d 6e 73 0a 20 20 20 20 20 20 o columns.
1db0: 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 (let* ((
1dc0: 70 72 65 66 69 78 20 28 6d 61 6b 65 2d 6e 6c 2d prefix (make-nl-
1dd0: 73 70 61 63 65 20 28 2b 20 63 6f 6c 20 31 29 29 space (+ col 1))
1de0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
1df0: 20 20 20 20 20 20 20 28 77 69 64 65 73 74 20 28 (widest (
1e00: 2b 20 31 20 28 63 61 72 20 6c 73 29 29 29 0a 20 + 1 (car ls))).
1e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1e20: 20 20 20 20 28 63 6f 6c 75 6d 6e 73 20 28 71 75 (columns (qu
1e30: 6f 74 69 65 6e 74 20 77 69 64 74 68 20 77 69 64 otient width wid
1e40: 65 73 74 29 29 29 20 3b 20 61 6c 77 61 79 73 20 est))) ; always
1e50: 3e 3d 20 32 0a 20 20 20 20 20 20 20 20 20 20 20 >= 2.
1e60: 20 20 20 20 20 28 6c 65 74 20 6c 70 20 28 28 6c (let lp ((l
1e70: 73 20 28 63 64 72 20 6c 73 29 29 20 28 73 74 20 s (cdr ls)) (st
1e80: 73 74 32 29 20 28 69 20 31 29 29 0a 20 20 20 20 st2) (i 1)).
1e90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
1ea0: 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 ond.
1eb0: 20 20 20 20 20 20 20 20 28 28 6e 75 6c 6c 3f 20 ((null?
1ec0: 6c 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ls).
1ed0: 20 20 20 20 20 20 20 20 20 28 6f 75 74 70 75 74 (output
1ee0: 20 22 29 22 20 73 74 29 29 0a 20 20 20 20 20 20 ")" st)).
1ef0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 ((
1f00: 6e 75 6c 6c 3f 20 28 63 64 72 20 6c 73 29 29 0a null? (cdr ls)).
1f10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1f20: 20 20 20 20 20 28 6f 75 74 70 75 74 20 22 29 22 (output ")"
1f30: 20 28 6f 75 74 70 75 74 20 28 63 61 72 20 6c 73 (output (car ls
1f40: 29 20 73 74 29 29 29 0a 20 20 20 20 20 20 20 20 ) st))).
1f50: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 (els
1f60: 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 e.
1f70: 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 73 74 (let ((st
1f80: 20 28 6f 75 74 70 75 74 20 28 63 61 72 20 6c 73 (output (car ls
1f90: 29 20 73 74 29 29 29 0a 20 20 20 20 20 20 20 20 ) st))).
1fa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
1fb0: 69 66 20 28 3e 3d 20 69 20 63 6f 6c 75 6d 6e 73 if (>= i columns
1fc0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
1fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 70 (lp
1fe0: 20 28 63 64 72 20 6c 73 29 20 28 6f 75 74 70 75 (cdr ls) (outpu
1ff0: 74 20 70 72 65 66 69 78 20 73 74 29 20 31 29 0a t prefix st) 1).
2000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2010: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a (let*
2020: 20 28 28 70 61 64 20 28 2d 20 77 69 64 65 73 74 ((pad (- widest
2030: 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 (string-length
2040: 28 63 61 72 20 6c 73 29 29 29 29 0a 20 20 20 20 (car ls)))).
2050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
2070: 74 20 28 6f 75 74 70 75 74 20 28 6d 61 6b 65 2d t (output (make-
2080: 73 70 61 63 65 20 70 61 64 29 20 73 74 29 29 29 space pad) st)))
2090: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
20a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
20b0: 70 20 28 63 64 72 20 6c 73 29 20 73 74 20 28 2b p (cdr ls) st (+
20c0: 20 69 20 31 29 29 29 29 29 29 29 29 29 29 29 0a i 1))))))))))).
20d0: 20 20 20 20 20 20 20 20 28 65 6c 73 65 0a 20 20 (else.
20e0: 20 20 20 20 20 20 20 3b 3b 20 6e 6f 20 72 6f 6f ;; no roo
20f0: 6d 2c 20 70 72 69 6e 74 20 6f 6e 65 20 70 65 72 m, print one per
2100: 20 6c 69 6e 65 0a 20 20 20 20 20 20 20 20 20 28 line. (
2110: 28 63 61 74 20 28 66 6d 74 2d 6a 6f 69 6e 20 70 (cat (fmt-join p
2120: 70 2d 6f 62 6a 65 63 74 20 6c 73 20 28 6d 61 6b p-object ls (mak
2130: 65 2d 6e 6c 2d 73 70 61 63 65 20 63 6f 6c 29 29 e-nl-space col))
2140: 20 22 29 22 29 20 73 74 29 29 29 29 29 29 0a 0a ")") st))))))..
2150: 28 64 65 66 69 6e 65 20 28 70 70 2d 76 65 63 74 (define (pp-vect
2160: 6f 72 20 76 65 63 29 0a 20 20 28 66 6d 74 2d 73 or vec). (fmt-s
2170: 68 61 72 65 64 2d 77 72 69 74 65 20 76 65 63 20 hared-write vec
2180: 28 63 61 74 20 22 23 22 20 28 70 70 2d 64 61 74 (cat "#" (pp-dat
2190: 61 2d 6c 69 73 74 20 28 76 65 63 74 6f 72 2d 3e a-list (vector->
21a0: 6c 69 73 74 20 76 65 63 29 29 29 29 29 0a 0a 28 list vec)))))..(
21b0: 64 65 66 69 6e 65 20 28 70 70 2d 6f 62 6a 65 63 define (pp-objec
21c0: 74 20 6f 62 6a 29 0a 20 20 28 63 6f 6e 64 0a 20 t obj). (cond.
21d0: 20 20 20 28 28 70 61 69 72 3f 20 6f 62 6a 29 20 ((pair? obj)
21e0: 28 70 70 2d 70 61 69 72 20 6f 62 6a 29 29 0a 20 (pp-pair obj)).
21f0: 20 20 20 28 28 76 65 63 74 6f 72 3f 20 6f 62 6a ((vector? obj
2200: 29 20 28 70 70 2d 76 65 63 74 6f 72 20 6f 62 6a ) (pp-vector obj
2210: 29 29 0a 20 20 20 20 28 65 6c 73 65 20 28 6c 61 )). (else (la
2220: 6d 62 64 61 20 28 73 74 29 20 28 28 77 72 69 74 mbda (st) ((writ
2230: 65 2d 77 69 74 68 2d 73 68 61 72 65 73 20 6f 62 e-with-shares ob
2240: 6a 20 28 66 6d 74 2d 73 68 61 72 65 73 20 73 74 j (fmt-shares st
2250: 29 29 20 73 74 29 29 29 29 29 0a 0a 28 64 65 66 )) st)))))..(def
2260: 69 6e 65 20 28 70 72 65 74 74 79 20 6f 62 6a 29 ine (pretty obj)
2270: 0a 20 20 28 66 6d 74 2d 62 69 6e 64 20 27 73 68 . (fmt-bind 'sh
2280: 61 72 65 73 20 28 63 6f 6e 73 20 28 6d 61 6b 65 ares (cons (make
2290: 2d 73 68 61 72 65 64 2d 72 65 66 2d 74 61 62 6c -shared-ref-tabl
22a0: 65 20 6f 62 6a 29 20 30 29 0a 20 20 20 20 20 20 e obj) 0).
22b0: 20 20 20 20 20 20 28 63 61 74 20 28 70 70 2d 6f (cat (pp-o
22c0: 62 6a 65 63 74 20 6f 62 6a 29 20 66 6c 29 29 29 bject obj) fl)))
22d0: 0a 0a 28 64 65 66 69 6e 65 20 28 70 72 65 74 74 ..(define (prett
22e0: 79 2f 75 6e 73 68 61 72 65 64 20 6f 62 6a 29 0a y/unshared obj).
22f0: 20 20 28 66 6d 74 2d 62 69 6e 64 20 27 73 68 61 (fmt-bind 'sha
2300: 72 65 73 20 28 63 6f 6e 73 20 28 6d 61 6b 65 2d res (cons (make-
2310: 65 71 3f 2d 74 61 62 6c 65 29 20 30 29 20 28 63 eq?-table) 0) (c
2320: 61 74 20 28 70 70 2d 6f 62 6a 65 63 74 20 6f 62 at (pp-object ob
2330: 6a 29 20 66 6c 29 29 29 0a 0a j) fl)))..