/usr/share/elk/pp.scm is in elk 3.99.8-2.1ubuntu2.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 | ;;; -*-Scheme-*-
;;;
;;; Trivial pretty-printer
(provide 'pp)
(define pp)
(let ((max-pos 55) (pos 0) (tab-stop 8))
(put 'lambda 'special #t)
(put 'macro 'special #t)
(put 'define 'special #t)
(put 'define-macro 'special #t)
(put 'define-structure 'special #t)
(put 'fluid-let 'special #t)
(put 'let 'special #t)
(put 'let* 'special #t)
(put 'letrec 'special #t)
(put 'case 'special #t)
(put 'call-with-current-continuation 'long #t)
(put 'quote 'abbr "'")
(put 'quasiquote 'abbr "`")
(put 'unquote 'abbr ",")
(put 'unquote-splicing 'abbr ",@")
(set! pp (lambda (x)
(set! pos 0)
(cond ((eq? (type x) 'compound)
(set! x (procedure-lambda x)))
((eq? (type x) 'macro)
(set! x (macro-body x))))
(fluid-let ((garbage-collect-notify? #f))
(pp-object x))
#v))
(define (flat-size s)
(fluid-let ((print-length 50) (print-depth 10))
(string-length (format #f "~a" s))))
(define (pp-object x)
(if (or (null? x) (pair? x))
(pp-list x)
(if (void? x)
(display "#v")
(write x))
(set! pos (+ pos (flat-size x)))))
(define (pp-list x)
(if (and (pair? x)
(symbol? (car x))
(string? (get (car x) 'abbr))
(= 2 (length x)))
(let ((abbr (get (car x) 'abbr)))
(display abbr)
(set! pos (+ pos (flat-size abbr)))
(pp-object (cadr x)))
(if (> (flat-size x) (- max-pos pos))
(pp-list-vertically x)
(pp-list-horizontally x))))
(define (pp-list-vertically x)
(maybe-pp-list-vertically #t x))
(define (pp-list-horizontally x)
(maybe-pp-list-vertically #f x))
(define (maybe-pp-list-vertically vertical? list)
(display "(")
(set! pos (1+ pos))
(if (null? list)
(begin
(display ")")
(set! pos (1+ pos)))
(let ((pos1 pos))
(pp-object (car list))
(if (and vertical?
(or
(and (pair? (car list))
(not (null? (cdr list))))
(and (symbol? (car list))
(get (car list) 'long))))
(indent-newline (1- pos1)))
(let ((pos2 (1+ pos)) (key (car list)))
(let tail ((flag #f) (l (cdr list)))
(cond ((pair? l)
(if flag
(indent-newline
(if (and (symbol? key) (get key 'special))
(1+ pos1)
pos2))
(display " ")
(set! pos (1+ pos)))
(pp-object (car l))
(tail vertical? (cdr l)))
(else
(cond ((not (null? l))
(display " . ")
(set! pos (+ pos 3))
(if flag (indent-newline pos2))
(pp-object l)))
(display ")")
(set! pos (1+ pos)))))))))
(define (indent-newline x)
(newline)
(set! pos x)
(let loop ((i x))
(cond ((>= i tab-stop)
(display "\t")
(loop (- i tab-stop)))
((> i 0)
(display " ")
(loop (1- i)))))))
|