klimi
/
dotfiles


								;;; 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)