dotfiles/emacs/.emacs.d/elpa/slime-20190724.1352/contrib/swank-macrostep.lisp

;;; swank-macrostep.lisp -- fancy macro-expansion via macrostep.el
;;
;; Authors: Luis Oliveira <luismbo@gmail.com>
;;          Jon Oddie <j.j.oddie@gmail.com>
;;
;; License: Public Domain

(defpackage swank-macrostep
  (:use cl swank)
  (:import-from swank
		#:*macroexpand-printer-bindings*
                #:with-buffer-syntax
		#:with-bindings
                #:to-string
                #:macroexpand-all
                #:compiler-macroexpand-1
                #:defslimefun
                #:collect-macro-forms)
  (:export #:macrostep-expand-1
           #:macro-form-p))

(in-package #:swank-macrostep)

(defslimefun macrostep-expand-1 (string compiler-macros? context)
  (with-buffer-syntax ()
    (let ((form (read-from-string string)))
      (multiple-value-bind (expansion error-message)
	  (expand-form-once form compiler-macros? context)
	(if error-message
            `(:error ,error-message)
	    (multiple-value-bind (macros compiler-macros)
		(collect-macro-forms-in-context expansion context)
	      (let* ((all-macros (append macros compiler-macros))
		     (pretty-expansion (pprint-to-string expansion))
		     (positions (collect-form-positions expansion
							pretty-expansion
							all-macros))
                     (subform-info
                      (loop
                         for form in all-macros
                         for (start end) in positions
                         when (and start end)
                         collect (let ((op-name (to-string (first form)))
                                       (op-type
                                        (if (member form macros)
                                            :macro
                                            :compiler-macro)))
                                   (list op-name
                                         op-type
                                         start)))))
		`(:ok ,pretty-expansion ,subform-info))))))))

(defun expand-form-once (form compiler-macros? context)
  (multiple-value-bind (expansion expanded?)
      (macroexpand-1-in-context form context)
    (if expanded?
	(values expansion nil)
	(if (not compiler-macros?)
	    (values nil "Not a macro form")
	    (multiple-value-bind (expansion expanded?)
		(compiler-macroexpand-1 form)
	      (if expanded?
		  (values expansion nil)
		  (values nil "Not a macro or compiler-macro form")))))))

(defslimefun macro-form-p (string compiler-macros? context)
  (with-buffer-syntax ()
    (let ((form
           (handler-case
               (read-from-string string)
             (error (condition)
               (unless (debug-on-swank-error)
                 (return-from macro-form-p
                   `(:error ,(format nil "Read error: ~A" condition))))))))
      `(:ok ,(macro-form-type form compiler-macros? context)))))

(defun macro-form-type (form compiler-macros? context)
  (cond
    ((or (not (consp form))
         (not (symbolp (car form))))
     nil)
    ((multiple-value-bind (expansion expanded?)
         (macroexpand-1-in-context form context)
       (declare (ignore expansion))
       expanded?)
     :macro)
    ((and compiler-macros?
          (multiple-value-bind (expansion expanded?)
              (compiler-macroexpand-1 form)
            (declare (ignore expansion))
            expanded?))
     :compiler-macro)
    (t
     nil)))


;;;; Hacks to support macro-expansion within local context

(defparameter *macrostep-tag* (gensym))

(defparameter *macrostep-placeholder* '*macrostep-placeholder*)

(define-condition expansion-in-context-failed (simple-error)
  ())

(defmacro throw-expansion (form &environment env)
  (throw *macrostep-tag* (macroexpand-1 form env)))

(defmacro throw-collected-macro-forms (form &environment env)
  (throw *macrostep-tag* (collect-macro-forms form env)))

(defun macroexpand-1-in-context (form context)
  (handler-case
      (macroexpand-and-catch
       `(throw-expansion ,form) context)
    (error ()
      (macroexpand-1 form))))

(defun collect-macro-forms-in-context (form context)
  (handler-case
      (macroexpand-and-catch
       `(throw-collected-macro-forms ,form) context)
    (error ()
      (collect-macro-forms form))))

(defun macroexpand-and-catch (form context)
  (catch *macrostep-tag*
    (macroexpand-all (enclose-form-in-context form context))
    (error 'expansion-in-context-failed)))

(defun enclose-form-in-context (form context)
  (with-buffer-syntax ()
    (destructuring-bind (prefix suffix) context
      (let* ((placeholder-form
              (read-from-string
               (concatenate
                'string
                prefix (prin1-to-string *macrostep-placeholder*) suffix)))
             (substituted-form (subst form *macrostep-placeholder*
                                      placeholder-form)))
        (if (not (equal placeholder-form substituted-form))
            substituted-form
            (error 'expansion-in-context-failed))))))


;;;; Tracking Pretty Printer

(defun marker-char-p (char)
  (<= #xe000 (char-code char) #xe8ff))

(defun make-marker-char (id)
  ;; using the private-use characters U+E000..U+F8FF as markers, so
  ;; that's our upper limit for how many we can use.
  (assert (<= 0 id #x8ff))
  (code-char (+ #xe000 id)))

(defun marker-char-id (char)
  (assert (marker-char-p char))
  (- (char-code char) #xe000))

(defparameter +whitespace+ (mapcar #'code-char '(9 13 10 32)))

(defun whitespacep (char)
  (member char +whitespace+))

(defun pprint-to-string (object &optional pprint-dispatch)
  (let ((*print-pprint-dispatch* (or pprint-dispatch *print-pprint-dispatch*)))
    (with-bindings *macroexpand-printer-bindings*
      (to-string object))))

#-clisp
(defun collect-form-positions (expansion printed-expansion forms)
  (loop for (start end)
     in (collect-marker-positions
         (pprint-to-string expansion (make-tracking-pprint-dispatch forms))
         (length forms))
     collect (when (and start end)
               (list (find-non-whitespace-position printed-expansion start)
                     (find-non-whitespace-position printed-expansion end)))))

;; The pprint-dispatch table constructed by
;; MAKE-TRACKING-PPRINT-DISPATCH causes an infinite loop and stack
;; overflow under CLISP version 2.49.  Make the COLLECT-FORM-POSITIONS
;; entry point a no-op in thi case, so that basic macro-expansion will
;; still work (without detection of inner macro forms)
#+clisp
(defun collect-form-positions (expansion printed-expansion forms)
  nil)

(defun make-tracking-pprint-dispatch (forms)
  (let ((original-table *print-pprint-dispatch*)
        (table (copy-pprint-dispatch)))
    (flet ((maybe-write-marker (position stream)
             (when position
               (write-char (make-marker-char position) stream))))
      (set-pprint-dispatch 'cons
                           (lambda (stream cons)
                             (let ((pos (position cons forms)))
                               (maybe-write-marker pos stream)
                               ;; delegate printing to the original table.
                               (funcall (pprint-dispatch cons original-table)
                                        stream
                                        cons)
                               (maybe-write-marker pos stream)))
                           most-positive-fixnum
                           table))
    table))

(defun collect-marker-positions (string position-count)
  (let ((positions (make-array position-count :initial-element nil)))
    (loop with p = 0
          for char across string
          unless (whitespacep char)
            do (if (marker-char-p char)
                   (push p (aref positions (marker-char-id char)))
                   (incf p)))
    (map 'list #'reverse positions)))

(defun find-non-whitespace-position (string position)
  (loop with non-whitespace-position = -1
        for i from 0 and char across string
        unless (whitespacep char)
          do (incf non-whitespace-position)
        until (eql non-whitespace-position position)
        finally (return i)))

(provide :swank-macrostep)