dotemacs

My Emacs configuration
git clone git://git.entf.net/dotemacs
Log | Files | Refs | LICENSE

collect-macro-forms.lisp (2425B)

      1 ;;; collect-macro-forms.lisp -- helper macros for slynk-macrostep.lisp
      2 ;;
      3 ;; Authors: Luís Oliveira <luismbo@gmail.com>
      4 ;;          Jon Oddie <j.j.oddie@gmail.com>
      5 ;;          João Távora <joaotavora@gmail.com>
      6 ;;
      7 ;; License: Public Domain
      8 
      9 (in-package #:slynk-macrostep)
     10 
     11 ;;; JT: These definitions brought into this contrib from SLIME's
     12 ;;; backend.lisp. They could/should go into SLY if they prove to be useful
     13 ;;; enough for writing other contribs, meanwhile keep them here.
     14 ;;; 
     15 (defmacro with-collected-macro-forms
     16     ((forms &optional result) instrumented-form &body body)
     17   "Collect macro forms by locally binding *MACROEXPAND-HOOK*.
     18 Evaluates INSTRUMENTED-FORM and collects any forms which undergo
     19 macro-expansion into a list.  Then evaluates BODY with FORMS bound to
     20 the list of forms, and RESULT (optionally) bound to the value of
     21 INSTRUMENTED-FORM."
     22   (assert (and (symbolp forms) (not (null forms))))
     23   (assert (symbolp result))
     24   ;; JT: Added conditional ignore spec
     25   ;; 
     26   (let ((result-var (or result
     27                         (gensym))))
     28     `(call-with-collected-macro-forms
     29       (lambda (,forms ,result-var)
     30         (declare (ignore ,@(unless result
     31                              `(,result-var))))
     32         ,@body)
     33       (lambda () ,instrumented-form))))
     34 
     35 (defun call-with-collected-macro-forms (body-fn instrumented-fn)
     36   (let ((return-value nil)
     37         (collected-forms '()))
     38     (let* ((real-macroexpand-hook *macroexpand-hook*)
     39            (*macroexpand-hook*
     40             (lambda (macro-function form environment)
     41               (let ((result (funcall real-macroexpand-hook
     42                                      macro-function form environment)))
     43                 (unless (eq result form)
     44                   (push form collected-forms))
     45                 result))))
     46       (setf return-value (funcall instrumented-fn)))
     47     (funcall body-fn collected-forms return-value)))
     48 
     49 (defun collect-macro-forms (form &optional env)
     50   "Collect subforms of FORM which undergo (compiler-)macro expansion.
     51 Returns two values: a list of macro forms and a list of compiler macro
     52 forms."
     53   (with-collected-macro-forms (macro-forms expansion)
     54       (ignore-errors (macroexpand-all form env))
     55     (with-collected-macro-forms (compiler-macro-forms)
     56         (handler-bind ((warning #'muffle-warning))
     57           (ignore-errors
     58             (compile nil `(lambda () ,expansion))))
     59       (values macro-forms compiler-macro-forms))))