388 lines
10 KiB
Plaintext
388 lines
10 KiB
Plaintext
;;; LISP9 GRIND
|
|
;;; Nils M Holm, 2018
|
|
;;; In the public domain
|
|
|
|
(def *grind-inline* nil)
|
|
(def *grind-margin* 72)
|
|
|
|
(defun (grind x)
|
|
|
|
(def offset 0)
|
|
(def column 0)
|
|
|
|
(def doprint t)
|
|
(def maxcol 0)
|
|
|
|
(def LP "(")
|
|
(def RP ")")
|
|
(def SP " ")
|
|
|
|
(defun (prc c)
|
|
(writec c))
|
|
|
|
(defun (probj x)
|
|
(princ x))
|
|
|
|
(defun (osize x)
|
|
(ssize (format x)))
|
|
|
|
(defun (bleedp x)
|
|
(>= (+ column (osize x)) *grind-margin*))
|
|
|
|
(defun (spaces n)
|
|
(and doprint
|
|
(or (= 0 n)
|
|
(prog (prc #\sp)
|
|
(spaces (- n 1))))))
|
|
|
|
(defun (linefeed)
|
|
(if doprint
|
|
(prc #\nl))
|
|
(spaces offset)
|
|
(setq column offset))
|
|
|
|
(defun (pr s)
|
|
(if doprint
|
|
(probj s))
|
|
(setq column (+ column (ssize s)))
|
|
(if (> column maxcol)
|
|
(setq maxcol column)))
|
|
|
|
(defun (simplep a)
|
|
(= (length a)
|
|
(length (filter atom a))))
|
|
|
|
(defun (indentp x)
|
|
(and (memq x '(catch
|
|
with-infile
|
|
with-outfile
|
|
with-inport
|
|
with-outport))
|
|
t))
|
|
|
|
(defun (willfit fmt x)
|
|
(with ((column column)
|
|
(offset offset)
|
|
(maxcol 0)
|
|
(doprint nil))
|
|
(fmt x)
|
|
(< maxcol *grind-margin*)))
|
|
|
|
(defun (pp-pair x)
|
|
(pr LP)
|
|
(with ((offset (+ 1 offset)))
|
|
(let loop ((x x)
|
|
(s nil))
|
|
(cond ((pair x)
|
|
(if s
|
|
(if (or (pair (car x))
|
|
(vectorp (car x)))
|
|
(linefeed)
|
|
(if (willfit pp-obj (car x))
|
|
(pr SP)
|
|
(linefeed))))
|
|
(pp-obj (car x))
|
|
(loop (cdr x) t))
|
|
((not (null x))
|
|
(pr " . ")
|
|
(pp-obj x)))))
|
|
(pr RP))
|
|
|
|
(defun (pp-obj x)
|
|
(cond ((or (eq t x)
|
|
(eq nil x)
|
|
(null x)
|
|
(symbolp x)
|
|
(charp x)
|
|
(fixp x)
|
|
(stringp x))
|
|
(pr (format x)))
|
|
((vectorp x)
|
|
(if doprint
|
|
(prc #\#))
|
|
(with ((offset (+ 1 offset)))
|
|
(pp-pair (veclist x))))
|
|
((pair x)
|
|
(pp-pair x))
|
|
((funp x)
|
|
(pr "#<function>"))
|
|
(else
|
|
(error "grind: unknown type" x))))
|
|
|
|
(defun (pp-body x)
|
|
(cond ((not (null x))
|
|
(pp-form (car x))
|
|
(if (not (null (cdr x)))
|
|
(linefeed))
|
|
(pp-body (cdr x)))))
|
|
|
|
(defun (pp-inline x)
|
|
(pr (format x)))
|
|
|
|
(defun (pp-indent x)
|
|
(pr LP)
|
|
(pr (symname (car x)))
|
|
(if (not (null (cdr x)))
|
|
(pr SP))
|
|
(with ((offset (+ 2 (osize (car x)) offset)))
|
|
(let loop ((x (cdr x)))
|
|
(cond ((not (null x))
|
|
(pp-form (car x))
|
|
(if (not (null (cdr x)))
|
|
(linefeed))
|
|
(loop (cdr x)))))
|
|
(pr RP)))
|
|
|
|
(defun (pp-indent-2 x)
|
|
(pr LP)
|
|
(with ((offset (+ 1 offset)))
|
|
(pp-form (car x)))
|
|
(let ((indent (if (pair (car x)) 1 2)))
|
|
(with ((offset (+ indent offset)))
|
|
(if (not (null (cdr x)))
|
|
(linefeed))
|
|
(pp-body (cdr x)))
|
|
(pr RP)))
|
|
|
|
(defun (pp-app x)
|
|
(let ((inl (willfit pp-inline x)))
|
|
(cond ((and inl (simplep x))
|
|
(pp-inline x))
|
|
((indentp (car x))
|
|
(pp-indent-2 x))
|
|
(inl
|
|
(pp-inline x))
|
|
((willfit pp-indent x)
|
|
(pp-indent x))
|
|
(else
|
|
(pp-indent-2 x)))))
|
|
|
|
(defun (pp-quote x)
|
|
(pr "'")
|
|
(with ((offset (+ 1 offset)))
|
|
(pp-obj (cadr x))))
|
|
|
|
(defun (pp-qquote x)
|
|
(let ((sym (case (car x)
|
|
((qquote) "@")
|
|
((unquote) ",")
|
|
((splice) ",@"))))
|
|
(pr sym)
|
|
(with ((offset (+ offset (ssize sym))))
|
|
(pp-form (cadr x)))))
|
|
|
|
(defun (pp-lambda x)
|
|
(cond ((or (not *grind-inline*)
|
|
(> (length x) 3)
|
|
(bleedp x))
|
|
(pr LP)
|
|
(pr "lambda ")
|
|
(with ((offset (+ 2 offset)))
|
|
(pp-obj (cadr x))
|
|
(linefeed)
|
|
(pp-body (cddr x))
|
|
(pr RP)))
|
|
(else
|
|
(pp-inline x))))
|
|
|
|
(defun (pp-lamapp x)
|
|
(cond ((or (not *grind-inline*)
|
|
(bleedp x))
|
|
(pr LP)
|
|
(with ((offset (+ 1 offset)))
|
|
(pp-lambda (car x)))
|
|
(if (not (null (cdr x)))
|
|
(linefeed))
|
|
(with ((offset (+ 1 offset)))
|
|
(pr SP)
|
|
(pp-body (cdr x)))
|
|
(pr RP))
|
|
(else
|
|
(pp-inline x))))
|
|
|
|
(defun (pp-down x)
|
|
(let ((inl (willfit pp-inline x)))
|
|
(cond ((and inl (simplep x))
|
|
(pp-inline x))
|
|
((willfit pp-indent x)
|
|
(pp-indent x))
|
|
(else
|
|
(pp-indent-2 x)))))
|
|
|
|
(defun (pp-bs bs rec)
|
|
(pr LP)
|
|
(with ((offset (+ 1 offset)))
|
|
(let loop ((bs bs))
|
|
(cond ((not (null bs))
|
|
(pr LP)
|
|
(pp-inline (caar bs))
|
|
(cond ((and rec
|
|
(pair (cadar bs))
|
|
(> (osize (caar bs)) 2))
|
|
(with ((offset (+ 2 offset)))
|
|
(linefeed)
|
|
(pp-form (cadar bs))))
|
|
(else
|
|
(pr SP)
|
|
(with ((offset (+ 2 (osize (caar bs))
|
|
offset)))
|
|
(pp-form (cadar bs)))))
|
|
(pr RP)
|
|
(if (not (null (cdr bs)))
|
|
(linefeed))
|
|
(loop (cdr bs))))))
|
|
(pr RP))
|
|
|
|
(defun (pp-bind x)
|
|
(let ((k (osize (car x))))
|
|
(pr LP)
|
|
(pr (symname (car x)))
|
|
(pr SP)
|
|
(let* ((namedp (symbolp (cadr x)))
|
|
(bs (if namedp (caddr x) (cadr x)))
|
|
(xs (if namedp (cdddr x) (cddr x)))
|
|
(k (if namedp
|
|
(+ 3 k (osize (cadr x)))
|
|
(+ 2 k))))
|
|
(with ((offset (+ k offset)))
|
|
(cond (namedp
|
|
(pp-inline (cadr x))
|
|
(pr SP)))
|
|
(pp-bs bs (eq (car x) 'labels)))
|
|
(with ((offset (+ 2 offset)))
|
|
(linefeed)
|
|
(pp-body xs))
|
|
(pr RP))))
|
|
|
|
(defun (pp-do x)
|
|
(let ((init-part cadr)
|
|
(test-part caddr)
|
|
(body cdddr))
|
|
(pr LP)
|
|
(pr "do ")
|
|
(pr LP)
|
|
(with ((offset (+ 5 offset)))
|
|
(let loop ((ini (init-part x)))
|
|
(cond ((null ini))
|
|
(else
|
|
(pp-app (car ini))
|
|
(if (not (null (cdr ini)))
|
|
(linefeed))
|
|
(loop (cdr ini))))))
|
|
(pr RP)
|
|
(with ((offset (+ 4 offset)))
|
|
(linefeed)
|
|
(pr LP)
|
|
(pp-form (car (test-part x)))
|
|
(if (not (null (cdr (test-part x))))
|
|
(with ((offset (+ 2 offset)))
|
|
(linefeed)
|
|
(pp-body (cdr (test-part x)))))
|
|
(pr RP))
|
|
(if (not (null (body x)))
|
|
(with ((offset (+ 2 offset)))
|
|
(linefeed)
|
|
(pp-body (body x))))
|
|
(pr RP)))
|
|
|
|
(defun (pp-cond x)
|
|
(labels
|
|
((pr-cs
|
|
(lambda (cs)
|
|
(cond ((null cs))
|
|
((null (cdar cs))
|
|
(pp-form (car cs))
|
|
(if (not (null (cdr cs)))
|
|
(linefeed))
|
|
(pr-cs (cdr cs)))
|
|
((eq '=> (cadar cs))
|
|
(pr LP)
|
|
(pp-form (caar cs))
|
|
(linefeed)
|
|
(pr " => ")
|
|
(with ((offset column))
|
|
(pp-body (cddar cs))
|
|
(pr RP))
|
|
(if (not (null (cdr cs)))
|
|
(linefeed))
|
|
(pr-cs (cdr cs)))
|
|
(else
|
|
(pr LP)
|
|
(with ((offset (+ 1 offset)))
|
|
(if (eq (car x) 'cond)
|
|
(pp-form (caar cs))
|
|
(pp-obj (caar cs))))
|
|
(with ((offset (+ 2 offset)))
|
|
(linefeed)
|
|
(pp-body (cdar cs))
|
|
(pr RP))
|
|
(if (not (null (cdr cs)))
|
|
(linefeed))
|
|
(pr-cs (cdr cs)))))))
|
|
(pr LP)
|
|
(pr (symname (car x)))
|
|
(pr SP)
|
|
(let ((ind (if (and (eq 'cond (car x))
|
|
(willfit pr-cs (cdr x)))
|
|
6
|
|
2)))
|
|
(with ((offset (+ ind offset)))
|
|
(cond ((eq (car x) 'case)
|
|
(pp-inline (cadr x))
|
|
(linefeed)))
|
|
(let ((cs (if (eq (car x) 'cond)
|
|
(cdr x)
|
|
(cddr x))))
|
|
(pr-cs cs)
|
|
(pr RP))))))
|
|
|
|
(defun (pp-def x)
|
|
(pr LP)
|
|
(pr (symname (car x)))
|
|
(pr SP)
|
|
(pp-inline (cadr x))
|
|
(with ((offset (+ 2 offset)))
|
|
(if (or (and (pair (caddr x))
|
|
(eq 'lambda (caaddr x)))
|
|
(pair (cadr x))
|
|
(bleedp x))
|
|
(linefeed)
|
|
(pr SP))
|
|
(pp-body (cddr x)))
|
|
(pr RP))
|
|
|
|
(defun (pp-comm x)
|
|
(cond ((and (pair (cdr x))
|
|
(null (cddr x))
|
|
(stringp (cadr x)))
|
|
(pr ";")
|
|
(pr (cadr x))
|
|
(linefeed))
|
|
(else
|
|
(pp-app x))))
|
|
|
|
(defun (pp-form x)
|
|
(cond ((not (pair x))
|
|
(pp-obj x))
|
|
((and (pair (car x))
|
|
(eq 'lambda (caar x)))
|
|
(pp-lamapp x))
|
|
(else
|
|
(case (car x)
|
|
((quote) (pp-quote x))
|
|
((qquote unquote splice) (pp-qquote x))
|
|
((lambda) (pp-lambda x))
|
|
((cond case) (pp-cond x))
|
|
((do) (pp-do x))
|
|
((if if* and or prog) (pp-down x))
|
|
((let let* labels with) (pp-bind x))
|
|
((def defun macro defmac) (pp-def x))
|
|
((--) (pp-comm x))
|
|
((setq) (pp-app x))
|
|
(else (pp-app x))))))
|
|
|
|
(pp-form x)
|
|
nil)
|
|
|
|
(def pp grind)
|