diff options
Diffstat (limited to 'vim/bundle/slimv/slime/contrib/swank-macrostep.lisp')
| -rw-r--r-- | vim/bundle/slimv/slime/contrib/swank-macrostep.lisp | 227 |
1 files changed, 227 insertions, 0 deletions
diff --git a/vim/bundle/slimv/slime/contrib/swank-macrostep.lisp b/vim/bundle/slimv/slime/contrib/swank-macrostep.lisp new file mode 100644 index 0000000..77dfa3f --- /dev/null +++ b/vim/bundle/slimv/slime/contrib/swank-macrostep.lisp @@ -0,0 +1,227 @@ +;;; swank-macrostep.lisp -- fancy macro-expansion via macrostep.el +;; +;; Authors: Luís 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) |