A missed test in the publication repo

Also a missed commit to metatronic which now is slightly more
configurable.

README.md

@@ -1691,7 +1691,7 @@ Metatronic macros make a lot of this pain go away: just give the symbols you wan
        ,@forms)))
 ```
 
-All that happens is that each symbol whose name looks like `<...>` is rewritten as a gensymized version of itself, with each identical symbol being rewritten to the same thing[^17].  As a special case, symbols whose names are `"<>"` are rewritten as unique gensymized symbols[^18].
+All that happens is that each symbol whose name looks like `<...>` is rewritten as a gensymized version of itself, with each identical symbol being rewritten to the same thing[^17].  As a special case, symbols whose names are `"<>"` are rewritten as unique gensymized symbols[^18].  The pattern symbols must match is controlled by a 'rewriter' function which can be changed if you don't like the default: see below.
 
 With the above definition
 
@@ -1721,9 +1721,7 @@ where, in this case, all the `#:<in>` symbols are the same symbol.
 - `form` is the form to be rewritten;
 - `rewrites`, if given, is a table of rewrites returned from a previous call to `metatronize`;
 - `sharing`, if given, is a table with information on structure sharing from a previous call to `metatronize` which it will use to possibly share structure with the `form` argument to that previous call;
-- `rewriter`, if given, is a function of one argument, a symbol, which should return either its argument and any value or a gensymized version of it and an indication of whether it should be stored in the rewrite table.
-
-If the last argument is given then it is used instead of the builtin metatronizer, so you can define your own notion of what symbols should be gensymized.
+- `rewriter`, if given, is a function of one argument, a symbol, which should return either its argument and any value or a gensymized version of it and an indication of whether it should be stored in the rewrite table.  The default value is `*default-metatronize-rewriter*`.
 
 `metatronize` returns four values:
 
@@ -1732,6 +1730,8 @@ If the last argument is given then it is used instead of the builtin metatronize
 - a list of unique symbols, which are usually the symbols that symbols whose names are `<>`get rewritten to;
 - a sharing table describing shared structure in the form.
 
+**`*default-metatronize-symbol-rewriter*`** is bound to the default symbol rewriter used by `metatronize`.  Changing it will change the behaviour of `metatronize` and therefore of `defmacro/m` and `macrolet/m`.  Reloading `metatronic` will reset it if you break things.
+
 ### Notes
 Macros written with `defmacro/m` and `macrolet/m` in fact metatronize symbols *twice*: once when the macro is defined, and then again when it is expanded, using lists of rewritten & unique symbols from the first metatronization to drive a `rewriter` function.  This ensures that each expansion has a unique set of gensymized symbols:  with the above definition of `with-file-lines`, then
 
@@ -2114,8 +2114,6 @@ I'm not completely convinced by the precision time code.
 
 Logging to pathnames rather than explicitly-managed streams may be a little slower, but seems now to be pretty close.
 
-`slog` will *certainly* turn into something which isn't a toy fairly soon: consider this an ephemeral version.
-
 ### Package, module
 `slog` lives in and provides `:org.tfeb.hax.slog`.
 

metatronic.lisp

@@ -10,15 +10,32 @@
   (:export
    #:defmacro/m
    #:macrolet/m
-   #:metatronize))
+   #:metatronize
+   #:default-metatronize-symbol-rewriter))
 
 (in-package :org.tfeb.hax.metatronic)
 
 (provide :org.tfeb.hax.metatronic)
 
+(defparameter *default-metatronize-symbol-rewriter* ;reload for sanity
+  (lambda (s)
+    (let* ((n (symbol-name s))
+           (l (length n)))
+      (if (and (>= l 2)
+               (char= (char n 0) #\<)
+               (char= (char n (1- l)) #\>))
+          (values (make-symbol n)
+                  (/= l 2))
+        (values s nil))))
+  "The default symbol rewriter used by METATRONIZE
+
+The initial value of this implements the bahviour described in the
+documentation: changing it will change the behaviour or DEFMACRO/M and
+MACROLET/M")
+
 (defun metatronize (form &key
                          (rewrites '()) (shares '())
-                         (rewriter nil))
+                         (rewriter *default-metatronize-symbol-rewriter*))
   ;; This has hard-wired knowledge of what a metatronic variable looks
   ;; like unless REWRITER is given
   "Return a metatronic version of FORM, the table of variables, a list
@@ -30,7 +47,8 @@ Arguments are FORM with keyword arguments
 - REWRITER, if given, should be a designator for a function of one
   argument, a symbol, which should either return the symbol or a
   metatronized symbol and an indication of whether it should be stored
-  in the rewrite table.
+  in the rewrite table.  The default value of REWRITER is
+  *DEFAULT-METATRONIZE-SYMBOL-REWRITER*.
 
 This only looks at list structure.  Sharing and circularity of list
 structure (only) is correctly copied."
@@ -43,27 +61,15 @@ structure (only) is correctly copied."
                   (let ((r (assoc this rtab)))
                     (if r
                         (cdr r)
-                      (if rewriter
-                          (multiple-value-bind (new storep)
-                              (funcall rewriter this)
-                            (if (eq new this)
-                                this
-                              (progn
-                                (if storep
-                                    (setf rtab (acons this new rtab))
-                                  (push new anons))
-                                new)))
-                        (let* ((n (symbol-name this))
-                               (l (length n)))
-                          (if (and (>= l 2)
-                                   (char= (char n 0) #\<)
-                                   (char= (char n (1- l)) #\>))
-                              (let ((s (make-symbol n)))
-                                (if (/= l 2)
-                                    (setf rtab (acons this s rtab))
-                                  (push s anons))
-                                s)
-                            this))))))
+                      (multiple-value-bind (new storep)
+                          (funcall rewriter this)
+                        (if (eq new this)
+                            this
+                          (progn
+                            (if storep
+                                (setf rtab (acons this new rtab))
+                              (push new anons))
+                            new))))))
                  (cons
                   (let ((seen (assoc this stab)))
                     (if seen

test/test-simple-loops.lisp

@@ -0,0 +1,73 @@
+;;;; Simple loop tests
+;;;
+;;; Mostly these are to check the values stuff.
+;;;
+
+#+org.tfeb.tools.require-module
+(org.tfeb.tools.require-module:needs
+ (:org.tfeb.hax.simple-loops :compile t)
+  #+Quicklisp
+  ("parachute" :fallback ql:quickload))
+
+(defpackage :org.tfeb.hax.simple-loops/test
+  (:use :cl :org.tfeb.hax.simple-loops :org.shirakumo.parachute))
+
+(in-package :org.tfeb.hax.simple-loops/test)
+
+(define-test "org.tfeb.hax.simple-loops")
+
+(define-test ("org.tfeb.hax.simple-loops" "doing values")
+  (is-values (doing ((i 0 (1+ i)))
+                 ((> i 1)))
+    (= 2))
+  (is-values (doing ((i 0 (1+ i))
+                     (j 0))
+                 ((> i 1)))
+    (= 2)
+    (= 0))
+  (is-values (doing ((i 0 (1+ i)))
+                 ((> i 1) 1))
+    (= 1))
+  (is-values (doing ((i 0 (1+ i)))
+                 ((> i 1) 1 2))
+    (= 1)
+    (= 2))
+  (is-values (doing ((i 0 (1+ i)))
+                 ((> i 1) (values 1 2)))
+    (= 1)
+    (= 2))
+  (is-values (doing ((i 0 (1+ i)))
+                 ((> i 1) (values 1 2) 3))
+    (= 1)
+    (= 2)
+    (= 3)))
+
+(define-test ("org.tfeb.hax.simple-loops" "looping/values inits")
+  (is-values (looping/values ((i j) (values 0 1))
+               (return (values i j)))
+    (= 0)
+    (= 1))
+  (is-values (looping/values ((i j) 0 1)
+               (return (values i j)))
+    (= 0)
+    (= 1))
+  (is-values (looping/values ((i j k) (values 0 1) 2)
+               (return (values i j k)))
+    (= 0)
+    (= 1)
+    (= 2)))
+
+(define-test ("org.tfeb.hax.simple-loops" "looping/values* iterate")
+  (is = (looping/values* (((i j) (values 0 1))
+                          ((k) 0))
+          (when (> k 3)
+            (return k))
+          (values i j (1+ k)))
+      4))
+
+(define-test ("org.tfeb.hax.simple-loops" "looping/values* sequential")
+  (finish (looping/values* (((i j) 0 1)
+                            ((k) i))
+            (return t))))
+
+(test "org.tfeb.hax.simple-loops" :report 'summary)