diff --git a/README.md b/README.md index c6e370f..170fc9f 100644 --- a/README.md +++ b/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 `#:` 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`. diff --git a/metatronic.lisp b/metatronic.lisp index 20b39c1..aa467ac 100644 --- a/metatronic.lisp +++ b/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 diff --git a/test/test-simple-loops.lisp b/test/test-simple-loops.lisp new file mode 100644 index 0000000..c8fbc96 --- /dev/null +++ b/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)