1 files changed, 262 insertions, 0 deletions
diff --git a/examples.lisp b/examples.lisp
new file mode 100644
index 0000000..e26e30b
--- /dev/null
+++ b/examples.lisp
@@ -0,0 +1,262 @@
+; (require :agnostic-lizard)
+(asdf:load-system :agnostic-lizard)
+; (use-package :agnostic-lizard)
+
+(defpackage :agnostic-lizard-tests
+  (:use :common-lisp :agnostic-lizard))
+(in-package :agnostic-lizard-tests)
+
+; different kind of expand can be defined
+
+(defmacro expand-f (form &environment e) `(macroexpand-all ',form ',e))
+(defmacro expand-m (form) `(macro-macroexpand-all ,form))
+(defmacro to-expanded (form) `(macro-walk-form ,form))
+
+(defvar *default-verbose* nil
+  "Whether verbose debugging output has to be printed")
+
+(defmacro check-eval-form (form &key (verbose *default-verbose*))
+  "Generate code checking correctness of expanding a form that can be eval-ed.
+This means that the correct expansion of the form may not depend on any lexical
+variable/function bindings (macros are OK).
+Correctness is defined just as returning the same value.
+"
+  `(let*
+     ((form-fe (expand-f ,form))
+      (form-me (expand-m ,form))
+      (value-oe ,form)
+      (value-fe (eval form-fe))
+      (value-me (eval form-me)))
+     (if
+       (and
+         (equal value-oe value-fe)
+         (equal value-oe value-me))
+       ,(when verbose
+          `(format *trace-output* "Checking form in eval OK:~{~%~S~}~%----~%"
+                   (list ',form form-fe form-me value-oe)))
+       (progn
+         (format
+           *error-output*
+           (concatenate
+             'string
+             "Mismatch when checking form:~%~s~%"
+             "Functional expansion:~%~S~%Macro-assisted expansion:~%~S~%"
+             "Original form value:~%~S~%"
+             "Functional expansion value: ~a~%~S~%"
+             "Macro-assisted expansion value: ~a~%~S~%")
+           ',form form-fe form-me value-oe
+           (if (equal value-oe value-fe) "OK" "!!") value-fe
+           (if (equal value-oe value-me) "OK" "!!") value-me)
+         (throw :eval-check-failed "Form expansion changed behaviour")))))
+
+(defmacro check-lexenv-form (form &key (verbose *default-verbose*))
+  "Generate code checking correctness of expanding a form that does use the
+lexical bindings of variables or functions."
+  `(progn
+     ,(when verbose
+        `(format *trace-output* "Checking form in lexenv:~%~S~%~S~%~S~%----~%"
+                 ',form (expand-m ,form) ,form))
+     (unless
+       (equal ,form (to-expanded ,form))
+       (throw :lexenv-check-fail "Form expansion changed behaviour"))))
+
+(defmacro full-check-form (form &key (verbose *default-verbose*))
+  "Generate code for both possible kinds of checks on a form."
+  `(progn
+     (check-eval-form ,form :verbose ,verbose)
+     (check-lexenv-form ,form :verbose ,verbose)))
+
+; Basic "making sense" checks
+(full-check-form 1)
+(full-check-form (let ((x 1)) x))
+(macrolet ((f () 1)) (full-check-form (f)))
+(macrolet ((f () 1)) (full-check-form (flet ((f () 2)) (f))))
+(full-check-form (list 2 2 (quote a)))
+(let ((x 1)) (check-lexenv-form (list x)))
+
+; A show-off of passing data through macrolet
+
+(defmacro depth-limited-macro (n-max on-failure &body body &environment env)
+  (let*
+    ((depth-value
+       (macroexpand-1
+         '(depth-counter-virtual-macro) env))
+     (depth (if (numberp depth-value) depth-value 0)))
+    (if
+      (> depth n-max)
+      ; Maximum macro depth reached
+      on-failure
+      (progn
+        `(macrolet
+           ((depth-counter-virtual-macro () ,(1+ depth)))
+           ,@body)))))
+
+(full-check-form
+  (depth-limited-macro
+    2
+    (depth-limited-macro
+      1
+      (depth-limited-macro 1 :max-depth :test))))
+
+(full-check-form
+  (depth-limited-macro
+    2 :max-depth
+    (depth-limited-macro
+      1 :max-depth
+      (depth-limited-macro 2 :max-depth :test))))
+
+(depth-limited-macro
+  2 :max-depth
+  (depth-limited-macro
+    1 :max-depth
+    (full-check-form
+      (depth-limited-macro 1 :max-depth :test))))
+
+(depth-limited-macro
+  2 :max-depth
+  (depth-limited-macro
+    1 :max-depth
+    (full-check-form
+      (depth-limited-macro 2 :max-depth :test))))
+
+(defmacro circular-depth-limited-macro ()
+  #1=(depth-limited-macro 100 :max-depth #1#))
+
+(full-check-form
+  (circular-depth-limited-macro)
+  ; printing the form is impossible
+  :verbose nil)
+
+(full-check-form (depth-limited-macro 2 nil (depth-limited-macro 3 nil (depth-counter-virtual-macro))))
+(depth-limited-macro 2 nil (depth-limited-macro 3 nil (full-check-form (depth-counter-virtual-macro))))
+(depth-limited-macro 2 nil (full-check-form (depth-limited-macro 3 nil (depth-counter-virtual-macro))))
+
+; New macroexpand-dammit fails on that
+(defmacro test-macro-just-one () 1)
+(full-check-form '(flet ((test-macro-just-one () 2)) (test-macro-just-one)))
+
+; Both old and new macroexpand-dammit fail here
+(full-check-form (macrolet ((test-macro-just-one () 2)) (macrolet () (test-macro-just-one))))
+(macrolet ((test-macro-just-one () 2)) (full-check-form (macrolet () (test-macro-just-one))))
+(macrolet ((test-macro-just-one () 2)) (macrolet () (full-check-form (test-macro-just-one))))
+
+; Parameters shadowing symbol-macros in flet
+(full-check-form
+  (symbol-macrolet
+    ((x 1))
+    (macrolet
+      ((f (x) `(+ ,x 2))
+       (g (x) `(+ ,x 3)))
+      (flet
+        ((f (x) (+ x 4))
+         (g (y) (f (+ x y 5))))
+        (g 77)))))
+(symbol-macrolet
+  ((x 1))
+  (full-check-form
+    (macrolet
+      ((f (x) `(+ ,x 2))
+       (g (x) `(+ ,x 3)))
+      (flet
+        ((f (x) (+ x 4))
+         (g (y) (f (+ x y 5))))
+        (g 77)))))
+(symbol-macrolet
+  ((x 1))
+  (macrolet
+    ((f (x) `(+ ,x 2))
+     (g (x) `(+ ,x 3)))
+    (full-check-form
+      (flet
+        ((f (x) (+ x 4))
+         (g (y) (f (+ x y 5))))
+        (g 77)))))
+(symbol-macrolet
+  ((x 1))
+  (macrolet
+    ((f (x) `(+ ,x 2))
+     (g (x) `(+ ,x 3)))
+    (flet
+      ((f (x) (+ x 4))
+       (g (y) (f (+ x y 5))))
+      (check-lexenv-form
+        (g 77)))))
+
+; the latest fork of macroexpand-dammit had a problem with that
+(full-check-form (funcall (lambda (x) x) :test))
+(full-check-form (defun just-a-test-function (x) x))
+
+; a silly set of macrolet tests
+(full-check-form
+  (macrolet ((ff (x) `(list ',x ',x)))
+    (macrolet
+      ((gg (y) `(ff ,y)))
+      (gg (1 2)))))
+(macrolet ((ff (x) `(list ',x ',x)))
+  (full-check-form
+    (macrolet
+      ((gg (y) `(ff ,y)))
+      (gg (1 2)))))
+(macrolet ((ff (x) `(list ',x ',x)))
+  (macrolet
+    ((gg (y) `(ff ,y)))
+    (full-check-form
+      (gg (1 2)))))
+
+(full-check-form
+  (macrolet ((ff (x) `(list ',x ',x)))
+    (macrolet
+      ((gg (y) `(ff ,y)))
+      (gg 3))))
+(macrolet ((ff (x) `(list ',x ',x)))
+  (full-check-form
+    (macrolet
+      ((gg (y) `(ff ,y)))
+      (gg 3))))
+(macrolet ((ff (x) `(list ',x ',x)))
+  (macrolet
+    ((gg (y) `(ff ,y)))
+    (full-check-form
+      (gg 3))))
+
+(full-check-form
+  (loop for j from 1 to 3 collect j))
+
+(full-check-form
+  (progn
+    (defun test-loop-function
+      (x y) (loop for j from 1 to 3 collect (+ x y j 1)))
+    (test-loop-function 12 36)))
+
+; quasi-unit-tests
+(full-check-form (block nil 1))
+(full-check-form (block nil (return 2) 1))
+
+(full-check-form '(1 2))
+
+(full-check-form (funcall (symbol-macrolet ((x y)) (lambda (x) (+ x 1))) 1))
+
+(macrolet
+  ((f (x) `(list ,x 1)))
+  (full-check-form (f (f 2))))
+(full-check-form
+  (macrolet
+    ((f (x) `(list ,x 1)))
+    (f (f 2))))
+
+;Tests from hu.dwim.walker
+(full-check-form
+  (macrolet ((++ (&body body)
+                 (reverse body)))
+    (++ 1 2 3 -)))
+(macrolet ((++ (&body body)
+               (reverse body)))
+  (full-check-form
+    (++ 1 2 3 -)))
+
+(full-check-form
+  (let ((obj (make-instance 'metaenv)))
+    (with-slots ((x agnostic-lizard::fallback-env)) obj
+      x)))
+
+(format *error-output* "Example run complete.~%")