1 (define show-parens

2 (lambda (x mode)

3 (case mode

4 ((eval) (list "(" x ")"))

5 ((quote) (list "[" x "]"))

6 ((meta-quote) (list "{" x "}"))

7 (else (error "Unknown show-mode" mode)))))

8

9 (define show-join

10 (lambda (mid xs)

11 (if (null? xs)

12 '()

13 (reverse (fold (lambda (x acc)

14 (cons x (cons mid acc)))

15 (list (car xs))

16 (cdr xs))))))

17

18 (define show-tng

19 (lambda (c mode)

20 (let walk ((c c))

21 (case (car c)

22 ((tuple) (show-join ", " (map walk (cdr c))))

23 ((atom) (list "#" (symbol->string (cadr c))))

24 ((lit) (let ((o (open-output-string)))

25 (display (cadr c) o)

26 (get-output-string o)))

27 ((adj) (list (walk (cadr c)) " " (walk (caddr c))))

28 ((fun) (show-join " " (map (lambda (entry)

29 (list (show-tng (car entry) 'quote) ": "

30 (show-tng (cadr entry) 'eval)))

31 (cdr c))))

32 ((eval) (if (eq? (car (cadr c)) 'atom)

33 (symbol->string (cadr (cadr c)))

34 (show-parens (show-tng (cadr c) 'eval) 'eval)))

35 ((quote) (show-parens (show-tng (cadr c) 'quote) 'quote))

36 ((meta-quote) (show-parens (show-tng (cadr c) 'meta-quote) 'meta-quote))

37 ((discard) "_")

38 (else (error "Unknown term in show-tng" c))))))

39

40 (define print-tng

41 (lambda (c mode)

42 (let walk ((x (show-tng c mode)))

43 (cond

44 ((null? x))

45 ((pair? x) (walk (car x)) (walk (cdr x)))

46 (else (display x))))))