Add binding / bind

trace-macroexpand also tries to handle bad tracing states much harder.

README.md

@@ -3,7 +3,9 @@ This repo contains a collection of small Common Lisp hacks I've written over the
 
 ## General
 ### Modules
-Each of these hacks is an independent module: it lives in its own little package and is loadable standalone: if you just want one of them then you don't need to drag all the unrelated ones into your environment.  If you put them in the right place, then [`require-module`](https://github.com/tfeb/tfeb-lisp-tools#requiring-modules-with-searching-require-module "require-module") will find and load them for you: this is how I use them.
+Almost all of these hacks are independent modules: they live in their own little packages and are loadable standalone: if you just want one of them then you don't need to drag all the unrelated ones into your environment.  If you put them in the right place, then [`require-module`](https://github.com/tfeb/tfeb-lisp-tools#requiring-modules-with-searching-require-module "require-module") will find and load them for you: this is how I use them.  Exceptions are:
+
+- `binding`, which depends on `collecting` and `iterate`, and will try to use `require-module` to load them if they're not already known when it's compiled or loaded.
 
 The system itself provides `:org.tfeb.hax`: there is no `org.tfeb.hax` package however: each component lives in its own package with names like `org.tfeb.hax.*`.
 
@@ -885,6 +887,88 @@ counter
 ### Package, module
 `define-functions` lives in `org.tfeb.hax.define-functions` and provides `:org.tfeb.hax.define-functions`.
 
+## Local bindings: `binding`
+Different languages take different approaches to declaring – *binding* variables and functions locally in code.
+
+- CL requires `let`, `labels` &c, which is clear but involves extra indentation;
+- Scheme allows local use of `define` which does not involve indentation, but does not allow it everywhere;
+- Python allows local bindings anywhere but the scope is insane (bindings have function scope and are thus visible before they appear textually) and variable binding is conflated with assignment which is just a horrible idea:
+- some C compilers may allow variable declarations almost anywhere with their scope starting from the point of declaration and running to the end of the block – I am not sure what the standard supports however;
+- Racket allows `define` in many more places than Scheme with their scope running to the end of the appropriate block.
+
+Racket is pretty clear how what it does works:
+
+```lisp
+...
+(define foo ...)
+...
+```
+
+turns into
+
+```lisp
+...
+(letrec ([foo ...])
+  ...)
+```
+
+I thought it would be fun to implement a form which does this for CL, and that's what `binding` does.
+
+**`binding`** is a form, directly within whose body several special binding forms are available.  These forms are:
+
+- `bind` will bind local variables or functions, corresponding to `let*` or `labels` respectively;
+- `bind/values` will bind multiple values, corresponding to `multiple-value-bind`;
+- `bind/destructuring` corresponds to `destructuring-bind`.
+
+For `bind` the two cases are:
+
+- `(bind var val)` will bind `var` to `val`using `let*`;
+- `(bind (f ...) ...)` will create a local function `f` using `labels` (the function definition form is like Scheme's `(define (f ...) ...)` syntax).
+
+For `bind/values` there are also two cases:
+
+- `(bind/values (...) form)` corresponds to `(multiple-value-bind (...) form ...)`
+- `(bind-values (...) form ...)` corresponds to `(multiple-value-bind (...) (values form ...) ...)`.
+
+`bind/destructuring` doesn't have any variants.
+
+All of these forms are coalesced to create the minimum number of binding constructs in the generated code (this is why `bind` corresponds to `let*`), so:
+
+```lisp
+(binding
+  (print 1)
+  (bind x 1)
+  (bind y 2)
+  (print 2)
+  (bind (f1 v)
+    (+ x v))
+  (bind (f2 v)
+    (+ y (f1 v)))
+  (f2 1))
+```
+
+corresponds to
+
+```lisp
+(progn
+  (print 1)
+  (let* ((x 1) (y 2))
+    (print 2)
+    (labels ((f1 (v)
+               (+ x v))
+             (f2 (v)
+               (+ y (f1 v))))
+      (f2 1))))
+```
+
+and so on. `bind/values` and `bind/destructuring` are not coalesced as it makes no sense to do so.
+
+### Notes
+`bind` &c work *only* directly within `binding`: there is no code walker, intentionally so.  There are top-level definitions of `bind` &c as macros which signal errors at macroexpansion time.
+
+### Package, module, dependencies
+`binding` lives in `org.tfeb.hax.binding`and provides `:org.tfeb.hax.binding`.  `binding` depends on `collecting` and `iterate` at compile and run time.  If you load it as a module then, if you have [`require-module`](https://github.com/tfeb/tfeb-lisp-tools#requiring-modules-with-searching-require-module "require-module"), it will use that to try and load them if they're not there.  If it can't do that and they're not there you'll get a compile-time error.
+
 ----
 
 [^1]:	The initial documentation for these hacks was finished on 20210120 at 18:26 UTC: one hour and twenty-six minutes after Joe Biden became president of the United States.

binding.lisp

@@ -0,0 +1,236 @@
+;;;; Local definitions (like Racket)
+;;;
+;;; Like Racket (rather than Scheme) bindings can occur anywhere in a
+;;; BINDING form and an appropriately nested structure results.
+;;;
+;;; Bindings are only considered in the immediate children of BINDING
+;;; to avoid needing a code-walker.
+;;;
+;;; Within BINDING
+;;; - (bind var val) binds a variable;
+;;; - (bind (f ...) ...) binds a function (punning syntax like Scheme);
+;;; - (bind/values (...) form ...) binds multiple values -- if there
+;;;   is a single form it should return as many values as there are
+;;;   variables, otherwise there should be as many forms as values;
+;;; - (bind/destructuring dsll form) binds with destructuring;
+;;;
+;;; Successive bindings of the same kind (for BIND, not the other two)
+;;; are coalesced.
+;;;
+
+;;; Try to make this work as a module
+;;;
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (unless (and (member "ORG.TFEB.HAX.COLLECTING" *modules* :test #'string=)
+               (member "ORG.TFEB.HAX.ITERATE" *modules* :test #'string=))
+    #+org.tfeb.tools.require-module
+    (org.tfeb.tools.require-module:require-modules
+     '(:org.tfeb.hax.collecting
+       :org.tfeb.hax.iterate))
+    #-org.tfeb.tools.require-module
+    (error "doomed")))
+
+(defpackage :org.tfeb.hax.binding
+  (:use :cl
+   :org.tfeb.hax.collecting
+   :org.tfeb.hax.iterate)
+  (:export
+   #:binding
+   #:bind
+   #:bind/values
+   #:bind/destructuring))
+
+(in-package :org.tfeb.hax.binding)
+
+(provide :org.tfeb.hax.binding)
+
+;;; At top-level all these should be errors
+;;;
+
+(defmacro bind (name &body forms)
+  (declare (ignore forms))
+  (error "Trying to bind ~S outside binding" name))
+
+(defmacro bind/values (vars &body forms)
+  (declare (ignore forms))
+  (error "Trying to bind/values ~S outside binding" vars))
+
+(defmacro bind/destructuring (dsll form)
+  (declare (ignore form))
+  (error "Tryng to bind/destructuring ~A outside binding" dsll))
+
+(defun parse-binding-form (form)
+  ;; Return what sort of binding form this is, or NIL, and the
+  ;; corresponding binding, or NIL
+  (if (consp form)
+      (case (first form)
+        ((bind)
+         (unless (>= (length form) 2)
+           (error "hopless bind form ~S" form))
+         (typecase (first (rest form))
+             (symbol
+              (unless (<= (length form) 3)
+                (error "too many expressions in ~S" form))
+              (values 'variable (rest form)))
+             (cons
+              (values 'function `(,(first (first (rest form)))
+                                  ,(rest (first (rest form)))
+                                  ,@(rest (rest form)))))
+             (t
+              (error "mutant bind form ~S" form))))
+        ((bind/values)
+         (unless (>= (length form) 2)
+           (error "hopeless bind/values form ~S" form))
+         (let ((vars (first (rest form)))
+               (forms (rest (rest form))))
+           (unless (and (listp vars)
+                        (every #'symbolp vars))
+             (error "not all variables are in ~S" form))
+           (values 'values
+                   (if (= (length form) 3)
+                       (rest form)
+                     `(,vars (values ,@forms))))))
+        ((bind/destructuring)
+         (unless (= (length form) 3)
+           (error "hopeless bind/destructing form ~S" form))
+         (let ((dsll (first (rest form))))
+           (unless (listp dsll)
+             (error "destructuring lambda list isn't in ~S" form))
+           (values 'destructuring (rest form))))
+        (otherwise
+         (values nil nil)))
+    (values nil nil)))
+
+(defun walk-binding-body (body)
+  ;; Walk the body of a BINDING form.  This is just unavoidably hairy.
+  (collecting
+    (iterate wbb ((tail body)
+                  (variable-bindings '())
+                  (function-bindings '()))
+      (cond
+       (tail
+        (destructuring-bind (this . rest) tail
+          (multiple-value-bind (what binding) (parse-binding-form this)
+            (ecase what
+              ((variable)
+               (cond
+                (variable-bindings      ;been collecting vars
+                 (wbb rest (cons binding variable-bindings)
+                      function-bindings))
+                (function-bindings      ;been collecting fns
+                 (collect `(labels ,(reverse function-bindings)
+                             ,@(walk-binding-body tail))))
+                (t                      ;not collecting
+                 (wbb rest (cons binding variable-bindings) '()))))
+              ((function)
+               (cond
+                (function-bindings
+                 (wbb rest '() (cons binding function-bindings)))
+                (variable-bindings
+                 (collect `(let* ,(reverse variable-bindings)
+                             ,@(walk-binding-body tail))))
+                (t
+                 (wbb rest '() (cons binding function-bindings)))))
+              ((values)
+               (cond
+                (variable-bindings
+                 (collect
+                  `(let* ,(reverse variable-bindings)
+                     (multiple-value-bind ,(first binding) ,(second binding)
+                       ,@(walk-binding-body rest)))))
+                (function-bindings
+                 (collect
+                  `(labels ,(reverse function-bindings)
+                     (multiple-value-bind ,(first binding) ,(second binding)
+                       ,@(walk-binding-body rest)))))
+                (t
+                 (collect
+                  `(multiple-value-bind ,(first binding) ,(second binding)
+                     ,@(walk-binding-body rest))))))
+              ((destructuring)
+               (cond
+                (variable-bindings
+                 (collect
+                  `(let* ,(reverse variable-bindings)
+                     (destructuring-bind ,(first binding) ,(second binding)
+                       ,@(walk-binding-body rest)))))
+                (function-bindings
+                 (collect
+                  `(labels ,(reverse function-bindings)
+                     (destructuring-bind ,(first binding) ,(second binding)
+                       ,@(walk-binding-body rest)))))
+                (t
+                 (collect
+                  `(destructuring-bind ,(first binding) ,(second binding)
+                     ,@(walk-binding-body rest))))))
+              ((nil)
+               (cond
+                (variable-bindings
+                 (collect
+                  `(let* ,(reverse variable-bindings)
+                     ,this
+                     ,@(walk-binding-body rest))))
+                (function-bindings
+                 (collect
+                  `(labels ,(reverse function-bindings)
+                     ,this
+                     ,@(walk-binding-body rest))))
+                (t
+                 (collect this)
+                 (wbb rest '() '()))))))))
+       (variable-bindings
+        ;; hit end of body with pending variables: this only matters
+        ;; for side-effect
+        (collect `(let* ,(reverse variable-bindings))))
+       (function-bindings
+        ;; Pending functions, matters even less
+        (collect `(labels ,(reverse function-bindings))))))))
+
+(defmacro binding (&body forms)
+  ;; The macro itself
+  (let ((expanded (walk-binding-body forms)))
+    (if (= (length expanded) 1)
+        (first expanded)
+      `(progn ,@expanded))))
+
+;;; Rudimentary sanity tests
+;;;
+(dolist (form/expansion
+         '(((binding
+             (bind a 1)
+             (bind b 2)
+             (values a b))
+            (let* ((a 1) (b 2))
+             (values a b)))
+           ((binding
+             1
+             (bind b 2)
+             b)
+            (progn
+              1
+              (let* ((b 2))
+                b)))
+           ((binding
+             (bind (f &rest args) args)
+             (f 1 3))
+           (labels ((f (&rest args) args))
+             (f 1 3)))
+           ((binding
+             (bind/values (a b) (values 1 2))
+             (values a b))
+            (multiple-value-bind (a b) (values 1 2)
+             (values a b)))
+           ((binding
+              (bind/values (a b) 1 2)
+              (values a b))
+            (multiple-value-bind (a b) (values 1 2)
+             (values a b)))
+           ((binding
+             (bind/destructuring (a &rest b) (list 1 2))
+             (values a b))
+            (destructuring-bind (a &rest b) (list 1 2)
+             (values a b)))))
+  (destructuring-bind (form expansion) form/expansion
+    (unless (equal (macroexpand-1 form) expansion)
+      (warn "~S expanded to ~S, not ~S"
+            form (macroexpand-1 form) expansion))))

org.tfeb.hax.asd

@@ -5,7 +5,7 @@
 
 (defsystem "org.tfeb.hax"
   :description "TFEB hax"
-  :version "1.0.0"
+  :version "1.1.0"
   :author "Tim Bradshaw"
   :license "MIT"
   :homepage "https://github.com/tfeb/tfeb-lisp-hax"
@@ -23,6 +23,8 @@
    (:file "comment-form")
    (:file "define-functions")
    (:file "trace-macroexpand")
+   (:file "binding"
+    :depends-on ("collecting" "iterate"))
    (:file "hax-cometh"
     :depends-on ("collecting" "wrapping-standard"
                  "iterate" "dynamic-state" "memoize"

trace-macroexpand.lisp

@@ -176,13 +176,13 @@ The return value is ignored.")
                :format-control "No wrapped *MACROEXPAND-HOOK*?")
       (continue ()
         :report "Install FUNCALL as the wrapped hook"
-        (setq *wrapped-macroexpand-hook* 'funcall))
+        (setf *wrapped-macroexpand-hook* 'funcall))
       (store-value (v)
         :report "Set the wrapped hook to a value"
         :interactive (lambda ()
                        (format *query-io* "~&Value for wrapped hook: ")
                        (list (read *query-io*)))
-        (setq *wrapped-macroexpand-hook* v))))
+        (setf *wrapped-macroexpand-hook* v))))
   (if (trace-macroexpand-trace-p macro-function macro-form environment)
       (let ((expanded-form (funcall *wrapped-macroexpand-hook*
                                     macro-function macro-form environment)))
@@ -213,14 +213,14 @@ The return value is ignored.")
                    :format-control "Tracing on but no wrapped *MACROEXPAND-HOOK*?") ;
           (continue ()
             :report "Install FUNCALL as the wrapped hook"
-            (setq *wrapped-macroexpand-hook* 'funcall)
+            (setf *wrapped-macroexpand-hook* 'funcall)
             (values nil t))
           (store-value (v)
             :report "Set the wrapped hook to a value"
             :interactive (lambda ()
                            (format *query-io* "~&Value for wrapped hook: ")
                            (list (read *query-io*)))
-            (setq *wrapped-macroexpand-hook* v)
+            (setf *wrapped-macroexpand-hook* v)
             (values nil t))))
     (when *wrapped-macroexpand-hook*
       (restart-case