companion code for my local presentation "Code Walkers for Lisp"

code.lisp

;;;;
;;;; companion code for my presentation at a local meeting on 2019-09-28
;;;; (https://kansai-lisp-useres.connpass.com/event/142069/)
;;;;

;;;-------------------------------------------------------------------
;;; prerequisite

#|
(use-package :sb-walker)
(import 'sb-walker::walk-form-internal) ; for tracing
(ql:quickload "split-sequence")
(ql:quickload "cl-json")
|#

;;;-------------------------------------------------------------------
;;; with-gensyms / once-only -- from Practical Common Lisp by Peter Seibel

(defmacro with-gensyms ((&rest names) &body body)
  `(let ,(loop for n in names collect `(,n (gensym)))
     ,@body))

(defmacro once-only ((&rest names) &body body)
  (let ((gensyms (loop for n in names collect (gensym))))
    `(let (,@(loop for g in gensyms collect `(,g (gensym))))
       `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))
          ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))
                ,@body)))))


;;;-------------------------------------------------------------------
;;; walk-tree / walk-tree-atoms -- from CL tips by Zach Beane

(defun walk-tree (tree fn)      ; call FN for every subform (cons/atom)
  (subst-if t (constantly nil) tree :key fn))

(defun walk-tree-atoms (tree fn)
  (tree-equal tree tree         ; call FN for every atom
              :test (lambda (atom1 atom2)
                      (declare (ignore atom2))
                      (funcall fn atom1)
                      t)))

(defvar *my-repl*
  '(defun my-read-eval-print-loop (level)
    (with-simple-restart (abort "Exit command level ~D." level)
      (loop
        (with-simple-restart (abort "Return to command level ~D." level)
          (let ((form (prog2 (fresh-line) (read) (fresh-line))))
            (prin1 (eval form))))))))

(defun test-walk-tree ()
  (walk-tree *my-repl* #'print))


;;;-------------------------------------------------------------------
;;; my-macroexpand-all

(defmacro kond (&rest cls)
  (if cls
      `(if ,(caar cls)
           (progn ,@(cdar cls))
           (kond ,@(cdr cls)))))

(defun my-macroexpand-all (tree)
  (let ((x (macroexpand tree)))
    (if (atom x) x (mapcar #'my-macroexpand-all x))))

(defun test-my-macroexpand-all ()
  (my-macroexpand-all
   '(mapcar #'(lmd (kond) (car kond)) list)
   )
  )


;;;-------------------------------------------------------------------
;;; macroexpand-all

#+:already-defined-above
(defvar *my-repl*
  '(defun my-read-eval-print-loop (level)
    (with-simple-restart (abort "Exit command level ~D." level)
      (loop
        (with-simple-restart (abort "Return to command level ~D." level)
          (let ((form (prog2 (fresh-line) (read) (fresh-line))))
            (prin1 (eval form))))))))

(defun test-mex-all (level &optional (form (fourth *my-repl*)))
  (ecase level
    (0 (macroexpand-1 form))
    (1 (macroexpand form))
    (2 (sb-cltl2:macroexpand-all form))))


;;;-------------------------------------------------------------------
;;; with-constant-folding

(defmacro with-constant-folding (&body body &environment env)
  (WALK-FORM `(progn ,@body) env
    (lambda (form context env2)
      (declare (ignore env2))
      (if (and (eq context :eval) (consp form)
               (member (car form) '(+ - * /))
               (every #'constantp (cdr form)))
          (eval form)
          form))))

(defun test-with-constant-folding ()
  (with-constant-folding
    (let (x (y 1))
      (setq x (+ 2 (* 3 4)))
      (/ (- y (* 24 7))
         (* 6 6)))))

;; the following is normally expanded into
;;   '(progn (setq x (+ 2 12) (/ (- y 168) 3600)))
;; but really expanded into
;;   '(progn (setq x 14) (/ (- y 168) 3600)))
;; in SBCL, which seems to evaluate (constantp '(* 3 4)) => T
(defun test-with-constant-folding-mex ()
  (macroexpand
   '(with-constant-folding
     (let (x (y 1))
       (setq x (+ 2 (* 3 4)))
       (/ (- y (* 24 7))
          (* 6 6))))))


;;;-------------------------------------------------------------------
;;; replacing every variable reference

(defvar *wcr-sample*
  '(let ((x (list Y)))
    (tagbody x
       (setq x (cons 'x X))
       (if (< (length X) 8) (go x)))
    (print X)))

(defun replace-varref (&optional (form *wcr-sample*) env)
  (WALK-FORM form env
    (lambda (form context env)
      (declare (ignore env))
      (if (and (eq context :eval)
               form
               (symbolp form)
;;             (VAR-LEXICAL-P form env)
               )
          "Foo"
          form))))

(defun replace-varref-lexvar-only (&optional (form *wcr-sample*) env)
  (WALK-FORM form env
    (lambda (form context env)
;;    (declare (ignore env))
      (if (and (eq context :eval)
               form
               (symbolp form)
               (VAR-LEXICAL-P form env)
               )
          "Foo"
          form))))


;;;-------------------------------------------------------------------
;;; aggregating closure variable in a lambda form

(defun lambda-form-p (form)
  (and (consp form)
       (eq (car form) 'lambda)
       (cadr form)))

(defun same-var-p (var env1 env2) ; variable-same-p in Fig.10 [2]
  (eq (VAR-LEXICAL-P var env1)
      (VAR-LEXICAL-P var env2)))

(defun aggregate (lmd-form lmd-env &aux (pool '()))
  (WALK-FORM lmd-form lmd-env
    (lambda (f c e)
      (when (and (eq c :eval) f (symbolp f) (same-var-p f e lmd-env))
        (pushnew f pool))
      f))
  pool)

(defvar *aggregate-sample*
  '(let (x y z) (lambda (y) (foo x y z))))

(defun test-aggregate (&optional (form *aggregate-sample*) env)
  (WALK-FORM form env
    (lambda (f c e)
      (declare (ignore c))
      (when (lambda-form-p f) (return-from test-aggregate (aggregate f e)))
      f)))

;;;-------------------------------------------------------------------
;;; alpha conversion

; currently no concrete samples -- sorry!


;;;-------------------------------------------------------------------
;;; a tiny symbol macro converted to an alist accessor

;(ql:quickload "split-sequence")
;(ql:quickload "cl-json")

(defun path-element-strings (s &optional (delimiter #\.))
  (split-sequence:split-sequence delimiter (subseq (string s) 1)))

(defun symbol-to-assoc-form (sym decoded-str)
  (flet ((fn (acc x)
           `(cdr (assoc ,x ,acc :test #'string-equal)))
         )
    (reduce #'fn (path-element-strings sym) :initial-value decoded-str)))

(defun free-varref-p (form ctxt env)
  (and form (symbolp form) (eq ctxt :eval)
       (cond ((VAR-LEXICAL-P form env) nil)
             ((sb-walker::variable-symbol-macro-p form env) nil)
             (t t))))

(defun @-prefixed-symbol-p (sym)
  (char= #\@ (char (symbol-name sym) 0)))

(defun walk-with-json-body (decoded-str form env)
  (WALK-FORM form env
             (lambda (subform ctxt subenv)
               (if (and (free-varref-p subform ctxt subenv)
                        (@-prefixed-symbol-p subform))
                   (symbol-to-assoc-form subform decoded-str)
                   subform))))

;;; (json:decode-json-from-string "{\"a\": 1, \"b\": {\"bb\": 2}, \"c\": 3}")
;;; => ((:A . 1) (:B (:BB . 2)) (:C . 3))
;;; Here we want to refer 1 by @a, 2 by @b.bb, and 3 by @c.
(defmacro with-json (json &body body &environment env)
  (let ((decoded (gensym)))
    `(let ((,decoded (json:decode-json-from-string ,json)))
       ,@(mapcar (lambda (form) (walk-with-json-body decoded form env))
                 body))))

(defun test-with-json ()
  (with-json "{\"a\": 1, \"b\": {\"bb\": 2}, \"c\": 3}"
    (let ((@c 999))
      (list :a @a :b.bb @b.bb :c @c
            (with-json "{\"a\": 10, \"b\": {\"bb\": 20}, \"c\": 30}"
              (let ((@c 9990))
                (list :a2 @a :b.bb2 @b.bb :c2 @c)))))))
; => (:A 1 :B.BB 2 :C 999 (:A2 10 :B.BB2 20 :C2 9990))


;;;; eof