[nongnu] elpa/macrostep b449cd0 059/110: Restore compiler-macro expansion under SLIME

[ELPA Syncer]

branch: elpa/macrostep
commit b449cd012a67c359886a51487ae275b59e6a3af2
Author: joddie <jonxfield@gmail.com>
Commit: joddie <jonxfield@gmail.com>

    Restore compiler-macro expansion under SLIME
---
 macrostep.el         |  26 ++++++++-----
 swank-macrostep.lisp | 108 ++++++++++++++++++++++++++++++++-------------------
 2 files changed, 85 insertions(+), 49 deletions(-)

diff --git a/macrostep.el b/macrostep.el
index b0c4aab..379b351 100644
--- a/macrostep.el
+++ b/macrostep.el
@@ -913,7 +913,9 @@ expansion will not be fontified.  See also
 (add-hook 'slime-mode-hook #'macrostep-slime-mode-hook)
 
 (defun macrostep-slime-expand-1 (string)
-  (slime-eval `(swank-macrostep:macrostep-expand-1 ,string nil)))
+  (slime-eval
+   `(swank-macrostep:macrostep-expand-1
+     ,string nil ,macrostep-expand-compiler-macros)))
 
 (defun macrostep-slime-insert (result)
   "Insert RESULT at point, indenting to match the current column."
@@ -935,17 +937,23 @@ expansion will not be fontified.  See also
       (save-excursion
         (goto-char start)
         (while (search-forward-regexp regexp end t)
-          (replace-match (assoc-default (match-string 2) substitutions)
-                         t t nil 2)
-          (put-text-property (match-beginning 1) (match-end 1)
-                             'macrostep-macro-start t)
-          (put-text-property (match-beginning 2) (match-end 2)
-                             'font-lock-face
-                             'macrostep-macro-face))))))
+          (pcase (assoc (match-string 2) substitutions)
+            (`(,_ ,original-symbol ,type)
+              (setq end (+ end (- (length original-symbol)
+                                  (length (match-string 2)))))
+              (replace-match original-symbol t t nil 2)
+              (put-text-property (match-beginning 1) (match-end 1)
+                                 'macrostep-macro-start t)
+              (put-text-property (match-beginning 2) (match-end 2)
+                                 'font-lock-face
+                                 (if (eq type :macro)
+                                     'macrostep-macro-face
+                                   'macrostep-compiler-macro-face)))))))))
 
 (defun macrostep-slime-macro-form-p (string)
   (slime-eval
-   `(swank-macrostep:macro-form-p ,string nil)))
+   `(swank-macrostep:macro-form-p
+     ,string nil ,macrostep-expand-compiler-macros)))
 
 (defun macrostep-slime-environment-at-point ()
   (save-excursion
diff --git a/swank-macrostep.lisp b/swank-macrostep.lisp
index e5b2310..b411051 100644
--- a/swank-macrostep.lisp
+++ b/swank-macrostep.lisp
@@ -4,7 +4,8 @@
   (:import-from swank
                 #:with-buffer-syntax
                 #:to-string
-                #:macroexpand-all)
+                #:macroexpand-all
+                #:compiler-macroexpand-1)
   (:export #:macrostep-expand-1
            #:macro-form-p))
 
@@ -14,20 +15,27 @@
   (with-buffer-syntax ()
     (let* ((form (read-from-string string))
            (bindings (mapcar #'read-from-string binding-strings))
-           (env (compute-environment bindings)))
-      (case (macro-form-type form env compiler-macros?)
-        (macro
-         (multiple-value-bind (expansion substitutions)
-             (substitute-macros (macroexpand-1 form env))
-           (list
-            (to-string expansion)
-            (loop for (replacement . original) in substitutions
-                 collect (cons (to-string replacement)
-                               (to-string original))))))
-        (compiler-macro
-         (error "Not implemented"))
-        (t
-         (error "Not a macro form"))))))
+           (env (compute-environment bindings))
+           (expansion
+            (multiple-value-bind (expansion expanded?)
+                (macroexpand-1 form env)
+              (if expanded?
+                  expansion
+                (if (not compiler-macros?)
+                    (error "Not a macro form.")
+                  (multiple-value-bind (expansion expanded?)
+                      (compiler-macroexpand-1 form env)
+                    (if expanded?
+                        expansion
+                      (error "Not a macro or compiler-macro form."))))))))
+      (multiple-value-bind (result substitutions)
+          (substitute-macros expansion)
+        (list
+         (to-string result)
+         (loop for (gensym original type) in substitutions
+            collect (list (to-string gensym)
+                          (to-string original)
+                          type)))))))
 
 (defun macro-form-p (string binding-strings &optional compiler-macros?)
   (with-buffer-syntax ()
@@ -42,10 +50,10 @@
          (not (symbolp (car sexp))))
      nil)
     ((macro-function (car sexp) environment)
-     'macro)
+     :macro)
     ((and compiler-macros?
           (compiler-macro-function (car sexp) environment))
-     'compiler-macro)
+     :compiler-macro)
     (t
      nil)))
 
@@ -63,8 +71,9 @@
       `(macrolet ,binding-list ,subexpression))))
 
 (defun substitute-macros (form)
-  (let ((forms (collect-macro-forms form)))
-    (substitute-macro-forms form forms)))
+  (multiple-value-bind (macro-forms compiler-macro-forms)
+      (collect-macro-forms form)
+    (substitute-macro-forms form macro-forms compiler-macro-forms)))
 
 (defun collect-macro-forms (form)
   (let* ((real-macroexpand-hook *macroexpand-hook*)
@@ -73,26 +82,45 @@
           (lambda (macro-function form environment)
             (setq macro-forms
                   (cons form macro-forms))
+            (funcall real-macroexpand-hook macro-function form environment)))
+         (expansion (ignore-errors (macroexpand-all form)))
+         (compiler-macro-forms '())
+         (*macroexpand-hook*
+          (lambda (macro-function form environment)
+            (setq compiler-macro-forms
+                  (cons form compiler-macro-forms))
             (funcall real-macroexpand-hook macro-function form environment))))
-    (macroexpand-all form)
-    macro-forms))
+    (ignore-errors
+      (compile nil `(lambda () ,expansion)))
+    (values macro-forms compiler-macro-forms)))
 
-(defun substitute-macro-forms (form forms)
-  (cond ((not (consp form))
-         (values form nil))
-        ((member form forms :test 'eq)
-         (multiple-value-bind (rest replacements)
-             (substitute-macro-forms (cdr form) forms)
-           (let ((replacement (gensym)))
-             (values
-              (cons replacement rest)
-              (cons (cons replacement (car form))
-                    replacements)))))
-        (t
-         (multiple-value-bind (car replacements-1)
-             (substitute-macro-forms (car form) forms)
-           (multiple-value-bind (cdr replacements-2)
-               (substitute-macro-forms (cdr form) forms)
-             (values
-              (cons car cdr)
-              (append replacements-1 replacements-2)))))))
+(defun substitute-macro-forms (form macro-forms compiler-macro-forms)
+  (labels
+      ((macro-form? (form)
+         (member form macro-forms :test 'eq))
+       (compiler-macro-form? (form)
+         (member form compiler-macro-forms :test 'eq))
+       (recur (form)
+         (let (macro? compiler-macro?)
+           (cond ((not (consp form))
+                  (values form nil))
+                 ((or
+                   (setf macro? (macro-form? form))
+                   (setf compiler-macro? (compiler-macro-form? form)))
+                  (multiple-value-bind (rest replacements)
+                      (recur (cdr form))
+                    (let ((replacement (gensym)))
+                      (values
+                       (cons replacement rest)
+                       (cons (list replacement (car form)
+                                   (if macro? :macro :compiler-macro))
+                             replacements)))))
+                 (t
+                  (multiple-value-bind (car replacements-1)
+                      (recur (car form))
+                    (multiple-value-bind (cdr replacements-2)
+                        (recur (cdr form))
+                      (values
+                       (cons car cdr)
+                       (append replacements-1 replacements-2)))))))))
+    (recur form)))