228 lines
7.9 KiB
Common Lisp
228 lines
7.9 KiB
Common 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)
|