slynk-macrostep.lisp (7754B)
1 ;;; slynk-macrostep.lisp -- fancy macro-expansion via macrostep.el 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 12 (defslyfun macrostep-expand-1 (string compiler-macros? context) 13 (with-buffer-syntax () 14 (let ((form (read-from-string string))) 15 (multiple-value-bind (expansion error-message) 16 (expand-form-once form compiler-macros? context) 17 (if error-message 18 `(:error ,error-message) 19 (multiple-value-bind (macros compiler-macros) 20 (collect-macro-forms-in-context expansion context) 21 (let* ((all-macros (append macros compiler-macros)) 22 (pretty-expansion (pprint-to-string expansion)) 23 (positions (collect-form-positions expansion 24 pretty-expansion 25 all-macros)) 26 (subform-info 27 (loop 28 for form in all-macros 29 for (start end) in positions 30 when (and start end) 31 collect (let ((op-name (to-string (first form))) 32 (op-type 33 (if (member form macros) 34 :macro 35 :compiler-macro))) 36 (list op-name 37 op-type 38 start))))) 39 `(:ok ,pretty-expansion ,subform-info)))))))) 40 41 (defun expand-form-once (form compiler-macros? context) 42 (multiple-value-bind (expansion expanded?) 43 (macroexpand-1-in-context form context) 44 (if expanded? 45 (values expansion nil) 46 (if (not compiler-macros?) 47 (values nil "Not a macro form") 48 (multiple-value-bind (expansion expanded?) 49 (compiler-macroexpand-1 form) 50 (if expanded? 51 (values expansion nil) 52 (values nil "Not a macro or compiler-macro form"))))))) 53 54 (defslyfun macro-form-p (string compiler-macros? context) 55 (with-buffer-syntax () 56 (let ((form 57 (handler-case 58 (read-from-string string) 59 (error (condition) 60 (unless (debug-on-slynk-error) 61 (return-from macro-form-p 62 `(:error ,(format nil "Read error: ~A" condition)))))))) 63 `(:ok ,(macro-form-type form compiler-macros? context))))) 64 65 (defun macro-form-type (form compiler-macros? context) 66 (cond 67 ((or (not (consp form)) 68 (not (symbolp (car form)))) 69 nil) 70 ((multiple-value-bind (expansion expanded?) 71 (macroexpand-1-in-context form context) 72 (declare (ignore expansion)) 73 expanded?) 74 :macro) 75 ((and compiler-macros? 76 (multiple-value-bind (expansion expanded?) 77 (compiler-macroexpand-1 form) 78 (declare (ignore expansion)) 79 expanded?)) 80 :compiler-macro) 81 (t 82 nil))) 83 84 85 ;;;; Hacks to support macro-expansion within local context 86 87 (defparameter *macrostep-tag* (gensym)) 88 89 (defparameter *macrostep-placeholder* '*macrostep-placeholder*) 90 91 (define-condition expansion-in-context-failed (simple-error) 92 ()) 93 94 (defmacro throw-expansion (form &environment env) 95 (throw *macrostep-tag* (macroexpand-1 form env))) 96 97 (defmacro throw-collected-macro-forms (form &environment env) 98 (throw *macrostep-tag* (collect-macro-forms form env))) 99 100 (defun macroexpand-1-in-context (form context) 101 (handler-case 102 (macroexpand-and-catch 103 `(throw-expansion ,form) context) 104 (error () 105 (macroexpand-1 form)))) 106 107 (defun collect-macro-forms-in-context (form context) 108 (handler-case 109 (macroexpand-and-catch 110 `(throw-collected-macro-forms ,form) context) 111 (error () 112 (collect-macro-forms form)))) 113 114 (defun macroexpand-and-catch (form context) 115 (catch *macrostep-tag* 116 (macroexpand-all (enclose-form-in-context form context)) 117 (error 'expansion-in-context-failed))) 118 119 (defun enclose-form-in-context (form context) 120 (with-buffer-syntax () 121 (destructuring-bind (prefix suffix) context 122 (let* ((placeholder-form 123 (read-from-string 124 (concatenate 125 'string 126 prefix (prin1-to-string *macrostep-placeholder*) suffix))) 127 (substituted-form (subst form *macrostep-placeholder* 128 placeholder-form))) 129 (if (not (equal placeholder-form substituted-form)) 130 substituted-form 131 (error 'expansion-in-context-failed)))))) 132 133 134 ;;;; Tracking Pretty Printer 135 136 (defun marker-char-p (char) 137 (<= #xe000 (char-code char) #xe8ff)) 138 139 (defun make-marker-char (id) 140 ;; using the private-use characters U+E000..U+F8FF as markers, so 141 ;; that's our upper limit for how many we can use. 142 (assert (<= 0 id #x8ff)) 143 (code-char (+ #xe000 id))) 144 145 (defun marker-char-id (char) 146 (assert (marker-char-p char)) 147 (- (char-code char) #xe000)) 148 149 (defparameter +whitespace+ (mapcar #'code-char '(9 13 10 32))) 150 151 (defun whitespacep (char) 152 (member char +whitespace+)) 153 154 (defun pprint-to-string (object &optional pprint-dispatch) 155 (let ((*print-pprint-dispatch* (or pprint-dispatch *print-pprint-dispatch*))) 156 (with-bindings *macroexpand-printer-bindings* 157 (to-string object)))) 158 159 #-clisp 160 (defun collect-form-positions (expansion printed-expansion forms) 161 (loop for (start end) 162 in (collect-marker-positions 163 (pprint-to-string expansion (make-tracking-pprint-dispatch forms)) 164 (length forms)) 165 collect (when (and start end) 166 (list (find-non-whitespace-position printed-expansion start) 167 (find-non-whitespace-position printed-expansion end))))) 168 169 ;; The pprint-dispatch table constructed by 170 ;; MAKE-TRACKING-PPRINT-DISPATCH causes an infinite loop and stack 171 ;; overflow under CLISP version 2.49. Make the COLLECT-FORM-POSITIONS 172 ;; entry point a no-op in thi case, so that basic macro-expansion will 173 ;; still work (without detection of inner macro forms) 174 #+clisp 175 (defun collect-form-positions (expansion printed-expansion forms) 176 nil) 177 178 (defun make-tracking-pprint-dispatch (forms) 179 (let ((original-table *print-pprint-dispatch*) 180 (table (copy-pprint-dispatch))) 181 (flet ((maybe-write-marker (position stream) 182 (when position 183 (write-char (make-marker-char position) stream)))) 184 (set-pprint-dispatch 'cons 185 (lambda (stream cons) 186 (let ((pos (position cons forms))) 187 (maybe-write-marker pos stream) 188 ;; delegate printing to the original table. 189 (funcall (pprint-dispatch cons original-table) 190 stream 191 cons) 192 (maybe-write-marker pos stream))) 193 most-positive-fixnum 194 table)) 195 table)) 196 197 (defun collect-marker-positions (string position-count) 198 (let ((positions (make-array position-count :initial-element nil))) 199 (loop with p = 0 200 for char across string 201 unless (whitespacep char) 202 do (if (marker-char-p char) 203 (push p (aref positions (marker-char-id char))) 204 (incf p))) 205 (map 'list #'reverse positions))) 206 207 (defun find-non-whitespace-position (string position) 208 (loop with non-whitespace-position = -1 209 for i from 0 and char across string 210 unless (whitespacep char) 211 do (incf non-whitespace-position) 212 until (eql non-whitespace-position position) 213 finally (return i))) 214 215 (provide :slynk-macrostep)